From 2fcac97d03014bb5fa558a08a65d9581390c98bf Mon Sep 17 00:00:00 2001
From: Janus Weil <janus@gcc.gnu.org>
Date: Mon, 23 Aug 2010 14:26:42 +0200
Subject: [PATCH] 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
---
gcc/fortran/ChangeLog | 8 ++
gcc/fortran/resolve.c | 166 ++++++++++++----------
gcc/testsuite/ChangeLog | 5 +
gcc/testsuite/gfortran.dg/proc_ptr_29.f90 | 29 ++++
4 files changed, 132 insertions(+), 76 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_29.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fcad92f4717a..eba7534df860 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 63d33ce726a0..1d56ec6a867b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fe15bfa5eafb..f117080a577f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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>
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_29.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_29.f90
new file mode 100644
index 000000000000..69f0b0341960
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_29.f90
@@ -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" } }
--
GitLab