This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran, 4.5] PR38290: procedure pointer assignment checking
- From: "Janus Weil" <janus at gcc dot gnu dot org>
- To: gfortran <fortran at gcc dot gnu dot org>, "gcc patches" <gcc-patches at gcc dot gnu dot org>
- Date: Thu, 11 Dec 2008 23:09:47 +0100
- Subject: [Patch, Fortran, 4.5] PR38290: procedure pointer assignment checking
Hi all,
here comes my patch for PR38290. This fixes a couple of issues related
to PROCEDURE statements with intrinsic interfaces:
PROCEDURE(sin) :: p
For these the interface of the intrinsic is now correctly transferred
to the procedure symbol (the formal args were not copied at all, and
the typespec was copied too late).
In addition the interface check for procptr assignments has been
re-enabled. This check is done via gfc_compare_interfaces, which was
modified to also handle intrinsics.
Regtested on i686-pc-linux-gnu. Ok for 4.5?
Cheers,
Janus
2008-12-11 Janus Weil <janus@gcc.gnu.org>
PR fortran/38920
* expr.c (gfc_check_pointer_assign): Enable interface check for
procedure pointers.
* gfortran.h: Add copy_formal_args_intr.
* interface.c (gfc_compare_interfaces): Call gfc_compare_intr_interfaces
if second argument is an intrinsic.
(compare_intr_interfaces): Correctly set attr.function, attr.subroutine
and ts.
(compare_parameter): Call gfc_compare_interfaces also for intrinsics.
* resolve.c (resolve_specific_f0,resolve_specific_s0): Don't resolve
intrinsic interfaces here. Must happen earlier.
(resolve_symbol): Resolution of intrinsic interfaces moved here from
resolve_specific_..., and formal args are now copied from intrinsic
interfaces.
* symbol.c (copy_formal_args_intr): New function to copy the formal
arguments from an intinsic procedure.
2008-12-11 Janus Weil <janus@gcc.gnu.org>
PR fortran/38920
* gfortran.dg/proc_decl_1.f90: Modified.
* gfortran.dg/proc_ptr_11.f90: Extended.
Index: gcc/testsuite/gfortran.dg/proc_ptr_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (revision 142654)
+++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (working copy)
@@ -16,13 +16,35 @@ program bsp
procedure( up ) , pointer :: pptr
procedure(isign), pointer :: q
- ! TODO. See PR 38290.
- !pptr => add ! { "Interfaces don't match" }
+ procedure(iabs),pointer :: p1
+ procedure(f), pointer :: p2
+
+ pointer :: p3
+ interface
+ function p3(x)
+ real(8) :: p3,x
+ end function p3
+ end interface
+
+ pptr => add ! { dg-error "Interfaces don't match" }
q => add
print *, pptr() ! { dg-error "is not a function" }
+ p1 => iabs
+ p2 => iabs
+ p1 => f
+ p2 => f
+ p2 => p1
+ p1 => p2
+
+ p1 => abs ! { dg-error "Interfaces don't match" }
+ p2 => abs ! { dg-error "Interfaces don't match" }
+
+ p3 => dsin
+ p3 => sin ! { dg-error "Interfaces don't match" }
+
contains
function add( a, b )
@@ -31,4 +53,9 @@ program bsp
add = a + b
end function add
+ integer function f(x)
+ integer :: x
+ f = 317 + x
+ end function
+
end program bsp
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90 (revision 142654)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90 (working copy)
@@ -19,8 +19,15 @@ module m
public:: h
procedure(),public:: h ! { dg-error "was already specified" }
-end module m
+contains
+ subroutine abc
+ procedure() :: abc2
+ entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
+ real x
+ end subroutine
+
+end module m
program prog
@@ -68,13 +75,3 @@ contains
end subroutine foo
end program
-
-
-subroutine abc
-
- procedure() :: abc2
-
-entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
- real x
-
-end subroutine
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 142654)
+++ gcc/fortran/interface.c (working copy)
@@ -958,6 +958,9 @@ gfc_compare_interfaces (gfc_symbol *s1,
{
gfc_formal_arglist *f1, *f2;
+ if (s2->attr.intrinsic)
+ return compare_intr_interfaces (s1, s2);
+
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
return 0; /* Disagreement between function/subroutine. */
@@ -997,6 +1000,21 @@ compare_intr_interfaces (gfc_symbol *s1,
gfc_intrinsic_arg *fi, *f2;
gfc_intrinsic_sym *isym;
+ isym = gfc_find_function (s2->name);
+ if (isym)
+ {
+ if (!s2->attr.function)
+ gfc_add_function (&s2->attr, s2->name, &gfc_current_locus);
+ s2->ts = isym->ts;
+ }
+ else
+ {
+ isym = gfc_find_subroutine (s2->name);
+ gcc_assert (isym);
+ if (!s2->attr.subroutine)
+ gfc_add_subroutine (&s2->attr, s2->name, &gfc_current_locus);
+ }
+
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
return 0; /* Disagreement between function/subroutine. */
@@ -1013,12 +1031,6 @@ compare_intr_interfaces (gfc_symbol *s1,
return 1;
}
- isym = gfc_find_function (s2->name);
-
- /* This should already have been checked in
- resolve.c (resolve_actual_arglist). */
- gcc_assert (isym);
-
f1 = s1->formal;
f2 = isym->formal;
@@ -1454,12 +1466,7 @@ compare_parameter (gfc_symbol *formal, g
|| actual->symtree->n.sym->attr.external)
return 1; /* Assume match. */
- if (actual->symtree->n.sym->attr.intrinsic)
- {
- if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
- goto proc_fail;
- }
- else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
+ if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
goto proc_fail;
return 1;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 142654)
+++ gcc/fortran/symbol.c (working copy)
@@ -3831,6 +3831,59 @@ copy_formal_args (gfc_symbol *dest, gfc_
gfc_current_ns = parent_ns;
}
+void
+copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_intrinsic_arg *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ gfc_current_ns->proc_name = dest;
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->ts = curr_arg->ts;
+ formal_arg->sym->attr.optional = curr_arg->optional;
+ /*formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ copy_formal_args (formal_arg->sym, curr_arg->sym);*/
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ add_proc_interface (dest, IFSRC_DECL, head);
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
generic version of either the c_f_pointer or c_f_procpointer
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 142654)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2353,7 +2353,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymb
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
-void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
+void copy_formal_args (gfc_symbol *, gfc_symbol *);
+void copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 142654)
+++ gcc/fortran/expr.c (working copy)
@@ -3140,7 +3140,6 @@ gfc_check_pointer_assign (gfc_expr *lval
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
}
- /* TODO. See PR 38290.
if (rvalue->expr_type == EXPR_VARIABLE
&& lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
@@ -3149,7 +3148,7 @@ gfc_check_pointer_assign (gfc_expr *lval
gfc_error ("Interfaces don't match "
"in procedure pointer assignment at %L", &rvalue->where);
return FAILURE;
- }*/
+ }
return SUCCESS;
}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 142654)
+++ gcc/fortran/resolve.c (working copy)
@@ -1705,23 +1705,6 @@ resolve_specific_f0 (gfc_symbol *sym, gf
{
match m;
- /* See if we have an intrinsic interface. */
-
- if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym;
- isym = gfc_find_function (sym->ts.interface->name);
-
- /* Existence of isym should be checked already. */
- gcc_assert (isym);
-
- sym->ts.type = isym->ts.type;
- sym->ts.kind = isym->ts.kind;
- sym->attr.function = 1;
- sym->attr.proc = PROC_EXTERNAL;
- goto found;
- }
-
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
@@ -2788,24 +2771,6 @@ resolve_specific_s0 (gfc_code *c, gfc_sy
{
match m;
- /* See if we have an intrinsic interface. */
- if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
- && !sym->ts.interface->attr.subroutine
- && sym->ts.interface->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym;
-
- isym = gfc_find_function (sym->ts.interface->name);
-
- /* Existence of isym should be checked already. */
- gcc_assert (isym);
-
- sym->ts.type = isym->ts.type;
- sym->ts.kind = isym->ts.kind;
- sym->attr.subroutine = 1;
- goto found;
- }
-
if(sym->attr.is_iso_c)
{
m = gfc_iso_c_sub_interface (c,sym);
@@ -8992,10 +8957,33 @@ resolve_symbol (gfc_symbol *sym)
if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
{
gfc_symbol *ifc = sym->ts.interface;
- sym->ts = ifc->ts;
- sym->ts.interface = ifc;
- sym->attr.function = ifc->attr.function;
- sym->attr.subroutine = ifc->attr.subroutine;
+
+ if (ifc->attr.intrinsic)
+ {
+ gfc_intrinsic_sym *isym = gfc_find_function (sym->ts.interface->name);
+ if (isym)
+ {
+ sym->attr.function = 1;
+ sym->ts = isym->ts;
+ sym->ts.interface = ifc;
+ }
+ else
+ {
+ isym = gfc_find_subroutine (sym->ts.interface->name);
+ gcc_assert (isym);
+ sym->attr.subroutine = 1;
+ }
+ copy_formal_args_intr (sym, isym);
+ }
+ else
+ {
+ sym->ts = ifc->ts;
+ sym->ts.interface = ifc;
+ sym->attr.function = ifc->attr.function;
+ sym->attr.subroutine = ifc->attr.subroutine;
+ copy_formal_args (sym, ifc);
+ }
+
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.pure = ifc->attr.pure;
@@ -9003,7 +8991,6 @@ resolve_symbol (gfc_symbol *sym)
sym->attr.dimension = ifc->attr.dimension;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
- copy_formal_args (sym, ifc);
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
if (sym->as)