OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/45366 (Problem with procedure pointer dummy in PURE function) 

2010-08-23  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45366
	* resolve.c (resolve_procedure_interface): New function split off from
	'resolve_symbol'.
	(resolve_formal_arglist): Call it here ...
	(resolve_symbol): ... and here.


2010-08-23  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45366
	* gfortran.dg/proc_ptr_29.f90: New.

From-SVN: r163468
This commit is contained in:
Janus Weil 2010-08-23 14:26:42 +02:00
parent 5573628560
commit 2fcac97d03
4 changed files with 132 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2010-08-23 Janus Weil <janus@gcc.gnu.org>
PR fortran/45366
* resolve.c (resolve_procedure_interface): New function split off from
'resolve_symbol'.
(resolve_formal_arglist): Call it here ...
(resolve_symbol): ... and here.
2010-08-22 Joseph Myers <joseph@codesourcery.com>
* Make-lang.in (gfortranspec.o): Update dependencies.

166
gcc/fortran/resolve.c
View File

@ -126,6 +126,88 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
}
static void resolve_symbol (gfc_symbol *sym);
static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
static gfc_try
resolve_procedure_interface (gfc_symbol *sym)
{
if (sym->ts.interface == 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)
{
gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
"in a later PROCEDURE statement", sym->ts.interface->name,
sym->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)
{
gfc_symbol *ifc = sym->ts.interface;
resolve_symbol (ifc);
if (ifc->attr.intrinsic)
resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
sym->ts = ifc->result->ts;
else
sym->ts = ifc->ts;
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
sym->attr.subroutine = ifc->attr.subroutine;
gfc_copy_formal_args (sym, ifc);
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.pure = ifc->attr.pure;
sym->attr.elemental = ifc->attr.elemental;
sym->attr.dimension = ifc->attr.dimension;
sym->attr.contiguous = ifc->attr.contiguous;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
if (sym->as)
{
int i;
for (i = 0; i < sym->as->rank; i++)
{
gfc_expr_replace_symbols (sym->as->lower[i], sym);
gfc_expr_replace_symbols (sym->as->upper[i], sym);
}
}
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
return FAILURE;
}
}
else if (sym->ts.interface->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
sym->ts.interface->name, sym->name, &sym->declared_at);
return FAILURE;
}
return SUCCESS;
}
/* Resolve types of formal argument lists. These have to be done early so that
the formal argument lists of module procedures can be copied to the
containing module before the individual procedures are resolved
@ -174,6 +256,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);
if (sym->attr.if_source != IFSRC_UNKNOWN)
resolve_formal_arglist (sym);
@ -10970,9 +11055,6 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
}
static void resolve_symbol (gfc_symbol *sym);
/* Resolve the components of a derived type. */
static gfc_try
@ -11533,7 +11615,8 @@ resolve_symbol (gfc_symbol *sym)
gfc_component *c;
/* Avoid double resolution of function result symbols. */
if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
if ((sym->result || sym->attr.result) && !sym->attr.dummy
&& (sym->ns != gfc_current_ns))
return;
if (sym->attr.flavor == FL_UNKNOWN)
@ -11572,78 +11655,9 @@ resolve_symbol (gfc_symbol *sym)
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->ts.interface == sym)
{
gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
"interface", sym->name, &sym->declared_at);
return;
}
if (sym->ts.interface->attr.procedure)
{
gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
" in a later PROCEDURE statement", sym->ts.interface->name,
sym->name,&sym->declared_at);
return;
}
/* Get the attributes from the interface (now resolved). */
if (sym->ts.interface->attr.if_source
|| sym->ts.interface->attr.intrinsic)
{
gfc_symbol *ifc = sym->ts.interface;
resolve_symbol (ifc);
if (ifc->attr.intrinsic)
resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
sym->ts = ifc->result->ts;
else
sym->ts = ifc->ts;
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
sym->attr.subroutine = ifc->attr.subroutine;
gfc_copy_formal_args (sym, ifc);
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.pure = ifc->attr.pure;
sym->attr.elemental = ifc->attr.elemental;
sym->attr.dimension = ifc->attr.dimension;
sym->attr.contiguous = ifc->attr.contiguous;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
if (sym->as)
{
int i;
for (i = 0; i < sym->as->rank; i++)
{
gfc_expr_replace_symbols (sym->as->lower[i], sym);
gfc_expr_replace_symbols (sym->as->upper[i], sym);
}
}
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
return;
}
}
else if (sym->ts.interface->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
sym->ts.interface->name, sym->name, &sym->declared_at);
return;
}
}
&& sym->attr.if_source != IFSRC_DECL
&& resolve_procedure_interface (sym) == FAILURE)
return;
if (sym->attr.is_protected && !sym->attr.proc_pointer
&& (sym->attr.procedure || sym->attr.external))

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2010-08-23 Janus Weil <janus@gcc.gnu.org>
PR fortran/45366
* gfortran.dg/proc_ptr_29.f90: New.
2010-08-22 Tobias Burnus <burnus@net-b.de>
Dominique d'Humieres <dominiq@lps.ens.fr>

29
gcc/testsuite/gfortran.dg/proc_ptr_29.f90 Normal file
View File

@ -0,0 +1,29 @@
! { dg-do compile }
!
! PR 45366: Problem with procedure pointer dummy in PURE function
!
! Contributed by Marco Restelli <mrestelli@gmail.com>
module m1
implicit none
abstract interface
pure function i_f(x) result(y)
real, intent(in) :: x
real :: y
end function i_f
end interface
end module m1
module m2
use m1, only: i_f
implicit none
contains
pure function i_g(x,p) result(y)
real, intent(in) :: x
procedure(i_f), pointer, intent(in) :: p
real :: y
y = p(x)
end function i_g
end module m2
! { dg-final { cleanup-modules "m1 m2" } }