git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/42418 (PROCEDURE: Rejects interface which is both specific and generic procedure) 

2012-07-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42418
	* decl.c (match_procedure_interface): Move some checks to
	'resolve_procedure_interface'. Set flavor if appropriate.
	* expr.c (gfc_check_pointer_assign): Cleanup of 'gfc_is_intrinsic'.
	* intrinsic.c (gfc_is_intrinsic): Additional checks for attributes which
	identify a procedure as being non-intrinsic.
	* resolve.c (resolve_procedure_interface): Checks moved here from
	'match_procedure_interface'. Minor cleanup.
	(resolve_formal_arglist,resolve_symbol): Cleanup of
	'resolve_procedure_interface'
	(resolve_actual_arglist,is_external_proc): Cleanup of
	'gfc_is_intrinsic'.

2012-07-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42418
	* gfortran.dg/proc_decl_29.f90: New.

From-SVN: r190017
This commit is contained in:
Janus Weil 2012-07-31 20:32:41 +02:00
parent ab6d55ef62
commit 0e8d854eb8
7 changed files with 111 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
2012-07-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/42418
* decl.c (match_procedure_interface): Move some checks to
'resolve_procedure_interface'. Set flavor if appropriate.
* expr.c (gfc_check_pointer_assign): Cleanup of 'gfc_is_intrinsic'.
* intrinsic.c (gfc_is_intrinsic): Additional checks for attributes which
identify a procedure as being non-intrinsic.
* resolve.c (resolve_procedure_interface): Checks moved here from
'match_procedure_interface'. Minor cleanup.
(resolve_formal_arglist,resolve_symbol): Cleanup of
'resolve_procedure_interface'
(resolve_actual_arglist,is_external_proc): Cleanup of
'gfc_is_intrinsic'.
2012-07-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/54134

33
gcc/fortran/decl.c
View File

@ -4792,41 +4792,20 @@ match_procedure_interface (gfc_symbol **proc_if)
gfc_current_ns = old_ns;
*proc_if = st->n.sym;
/* Various interface checks. */
if (*proc_if)
{
(*proc_if)->refs++;
/* Resolve interface if possible. That way, attr.procedure is only set
if it is declared by a later procedure-declaration-stmt, which is
invalid per C1212. */
invalid per F08:C1216 (cf. resolve_procedure_interface). */
while ((*proc_if)->ts.interface)
*proc_if = (*proc_if)->ts.interface;
if ((*proc_if)->generic)
{
gfc_error ("Interface '%s' at %C may not be generic",
(*proc_if)->name);
return MATCH_ERROR;
}
if ((*proc_if)->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Interface '%s' at %C may not be a statement function",
(*proc_if)->name);
return MATCH_ERROR;
}
/* Handle intrinsic procedures. */
if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc
|| (*proc_if)->attr.if_source == IFSRC_IFBODY)
&& (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus)
|| gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus)))
(*proc_if)->attr.intrinsic = 1;
if ((*proc_if)->attr.intrinsic
&& !gfc_intrinsic_actual_ok ((*proc_if)->name, 0))
{
gfc_error ("Intrinsic procedure '%s' not allowed "
"in PROCEDURE statement at %C", (*proc_if)->name);
return MATCH_ERROR;
}
if ((*proc_if)->attr.flavor == FL_UNKNOWN
&& (*proc_if)->ts.type == BT_UNKNOWN
&& gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
(*proc_if)->name, NULL) == FAILURE)
return MATCH_ERROR;
}
got_ts:

2
gcc/fortran/expr.c
View File

@ -3426,8 +3426,6 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
/* Check for intrinsics. */
gfc_symbol *sym = rvalue->symtree->n.sym;
if (!sym->attr.intrinsic
&& !(sym->attr.contained || sym->attr.use_assoc
|| sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
&& (gfc_is_intrinsic (sym, 0, sym->declared_at)
|| gfc_is_intrinsic (sym, 1, sym->declared_at)))
{

13
gcc/fortran/intrinsic.c
View File

@ -902,9 +902,9 @@ gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag)
}
/* Given a symbol, find out if it is (and is to be treated) an intrinsic. If
it's name refers to an intrinsic but this intrinsic is not included in the
selected standard, this returns FALSE and sets the symbol's external
/* Given a symbol, find out if it is (and is to be treated as) an intrinsic.
If its name refers to an intrinsic, but this intrinsic is not included in
the selected standard, this returns FALSE and sets the symbol's external
attribute. */
bool
@ -913,10 +913,13 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc)
gfc_intrinsic_sym* isym;
const char* symstd;
/* If INTRINSIC/EXTERNAL state is already known, return. */
/* If INTRINSIC attribute is already known, return. */
if (sym->attr.intrinsic)
return true;
if (sym->attr.external)
/* Check for attributes which prevent the symbol from being INTRINSIC. */
if (sym->attr.external || sym->attr.contained
|| sym->attr.if_source == IFSRC_IFBODY)
return false;
if (subroutine_flag)

65
gcc/fortran/resolve.c
View File

@ -146,24 +146,58 @@ static void resolve_symbol (gfc_symbol *sym);
static gfc_try
resolve_procedure_interface (gfc_symbol *sym)
{
if (sym->ts.interface == sym)
gfc_symbol *ifc = sym->ts.interface;
if (!ifc)
return SUCCESS;
/* Several checks for F08:C1216. */
if (ifc == sym)
{
gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->ts.interface->attr.procedure)
if (ifc->attr.procedure)
{
gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
"in a later PROCEDURE statement", sym->ts.interface->name,
"in a later PROCEDURE statement", ifc->name,
sym->name, &sym->declared_at);
return FAILURE;
}
if (ifc->generic)
{
/* For generic interfaces, check if there is
a specific procedure with the same name. */
gfc_interface *gen = ifc->generic;
while (gen && strcmp (gen->sym->name, ifc->name) != 0)
gen = gen->next;
if (!gen)
{
gfc_error ("Interface '%s' at %L may not be generic",
ifc->name, &sym->declared_at);
return FAILURE;
}
}
if (ifc->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Interface '%s' at %L may not be a statement function",
ifc->name, &sym->declared_at);
return FAILURE;
}
if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
|| gfc_is_intrinsic (ifc, 1, ifc->declared_at))
ifc->attr.intrinsic = 1;
if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
{
gfc_error ("Intrinsic procedure '%s' not allowed in "
"PROCEDURE statement at %L", ifc->name, &sym->declared_at);
return FAILURE;
}
/* Get the attributes from the interface (now resolved). */
if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
if (ifc->attr.if_source || ifc->attr.intrinsic)
{
gfc_symbol *ifc = sym->ts.interface;
resolve_symbol (ifc);
if (ifc->attr.intrinsic)
@ -212,10 +246,10 @@ resolve_procedure_interface (gfc_symbol *sym)
return FAILURE;
}
}
else if (sym->ts.interface->name[0] != '\0')
else if (ifc->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
sym->ts.interface->name, sym->name, &sym->declared_at);
ifc->name, sym->name, &sym->declared_at);
return FAILURE;
}
@ -273,9 +307,9 @@ resolve_formal_arglist (gfc_symbol *proc)
&proc->declared_at);
continue;
}
else if (sym->attr.procedure && sym->ts.interface
&& sym->attr.if_source != IFSRC_DECL)
resolve_procedure_interface (sym);
else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
&& resolve_procedure_interface (sym) == FAILURE)
return;
if (sym->attr.if_source != IFSRC_UNKNOWN)
resolve_formal_arglist (sym);
@ -1672,10 +1706,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
/* If a procedure is not already determined to be something else
check if it is intrinsic. */
if (!sym->attr.intrinsic
&& !(sym->attr.external || sym->attr.use_assoc
|| sym->attr.if_source == IFSRC_IFBODY)
&& gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
@ -2601,8 +2632,7 @@ static bool
is_external_proc (gfc_symbol *sym)
{
if (!sym->attr.dummy && !sym->attr.contained
&& !(sym->attr.intrinsic
|| gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
&& !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.proc_pointer
&& !sym->attr.use_assoc
@ -12516,8 +12546,7 @@ resolve_symbol (gfc_symbol *sym)
if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
if (sym->attr.procedure && sym->ts.interface
&& sym->attr.if_source != IFSRC_DECL
if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
&& resolve_procedure_interface (sym) == FAILURE)
return;

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2012-07-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/42418
* gfortran.dg/proc_decl_29.f90: New.
2012-07-31 Dehao Chen <dehao@google.com>
* gcc.dg/predict-7.c: New test.

30
gcc/testsuite/gfortran.dg/proc_decl_29.f90 Normal file
View File

@ -0,0 +1,30 @@
! { dg-do compile }
!
! PR 42418: PROCEDURE: Rejects interface which is both specific and generic procedure
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
interface gen
procedure gen
end interface
procedure(gen) :: p1
procedure(gen2) :: p2 ! { dg-error "may not be generic" }
procedure(sf) :: p3 ! { dg-error "may not be a statement function" }
procedure(char) :: p4
interface gen2
procedure char
end interface
sf(x) = x**2 ! { dg-warning "Obsolescent feature" }
contains
subroutine gen
end subroutine
subroutine char
end subroutine
end