[Patch, Fortran, 4.5] PR38290: procedure pointer assignment checking

["Janus Weil" <janus at gcc dot gnu dot org>]

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)