re PR other/38920 (dw2 exceptions don't work.)

2009-04-07  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.


2009-04-07  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/38920
	* gfortran.dg/proc_decl_1.f90: Modified.
	* gfortran.dg/proc_ptr_11.f90: Extended.
	* gfortran.dg/proc_ptr_13.f90: Modified.

From-SVN: r145651

10 files changed, 166 insertions, 70 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index bba5fe5..182e014 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,22 @@
+2009-04-07  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.
+
 2009-04-06  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/38863
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 233516e..94b8e0e 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3142,7 +3142,6 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 		     "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,
@@ -3151,7 +3150,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	  gfc_error ("Interfaces don't match "
 		     "in procedure pointer assignment at %L", &rvalue->where);
 	  return FAILURE;
-	}*/
+	}
       return SUCCESS;
     }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 4d04fda..7570f8d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2369,7 +2369,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 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  */
 
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 88638070..162816c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -967,6 +967,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
 {
   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.  */
@@ -1006,6 +1009,21 @@ compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
   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.  */
@@ -1022,12 +1040,6 @@ compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
 	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;
 
@@ -1463,12 +1475,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  || 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;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 32b13e4..1b866d9 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1742,23 +1742,6 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
 {
   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)
@@ -2795,24 +2778,6 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
 {
   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);
@@ -9201,10 +9166,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;
@@ -9212,7 +9200,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)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 7414616..6ffd869 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3839,6 +3839,59 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
   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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b4864a2..41488df 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2009-04-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/38920
+	* gfortran.dg/proc_decl_1.f90: Modified.
+	* gfortran.dg/proc_ptr_11.f90: Extended.
+	* gfortran.dg/proc_ptr_13.f90: Modified.
+
 2009-04-06  Jason Merrill  <jason@redhat.com>
 
 	PR c++/35146
diff --git a/gcc/testsuite/gfortran.dg/proc_decl_1.f90 b/gcc/testsuite/gfortran.dg/proc_decl_1.f90
index 392ce76..1df8b27 100644
--- a/gcc/testsuite/gfortran.dg/proc_decl_1.f90
+++ b/gcc/testsuite/gfortran.dg/proc_decl_1.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
index 69bf140..5c39f99 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
@@ -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 
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_13.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_13.f90
index a7f391f..a0e69af 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_13.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_13.f90
@@ -22,8 +22,7 @@ END MODULE myfortran_binding
 
 
 use myfortran_binding
-external foo
-error_handler => foo
+error_handler => error_stop
 end
 
 ! { dg-final { cleanup-modules "myfortran_binding" } }