Re: [Patch, fortran] PR40646 - ICE assigning array return value from type-bound procedure

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

> Ok, here is a rather complete patch, which (mostly) fixes the PPC part
> of the PR. Note that it fixes the attached versions of comment #2 and
> #4, but still has problems with certain variations of them.

Attached is a follow-up patch, which fixes the remaining issues (see
comment #8 in the PR).

Regression-tested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


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

	PR fortran/40646
	* module.c (mio_symbol): If the symbol has formal arguments,
	the formal namespace will be present.
	* resolve.c (resolve_actual_arglist): Correctly handle 'called'
	procedure pointer components as actual arguments.
	(resolve_fl_derived,resolve_symbol): Make sure the formal namespace
	is present.
	* trans-expr.c (gfc_conv_procedure_call): Correctly handle the formal
	arguments of procedure pointer components.


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

	PR fortran/40646
	* gfortran.dg/proc_ptr_22.f90: Extended.
	* gfortran.dg/proc_ptr_comp_12.f90: Extended.

Index: gcc/testsuite/gfortran.dg/proc_ptr_22.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_22.f90	(revision 149530)
+++ gcc/testsuite/gfortran.dg/proc_ptr_22.f90	(working copy)
@@ -7,6 +7,7 @@
 
 module bugTestMod
   implicit none
+  procedure(returnMat), pointer :: pp2
 contains
   function returnMat( a, b ) result( mat )
     integer:: a, b
@@ -21,6 +22,8 @@ program bugTest
   procedure(returnMat), pointer :: pp
   pp => returnMat
   if (sum(pp(2,2))/=4) call abort()
+  pp2 => returnMat
+  if (sum(pp2(3,2))/=6) call abort()
 end program bugTest
 
 ! { dg-final { cleanup-modules "bugTestMod" } }
Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_12.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_12.f90	(revision 149530)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_12.f90	(working copy)
@@ -27,6 +27,8 @@ program bugTest
   testCatch = testObj%test(2,2)
   print *,testCatch
   if (sum(testCatch)/=4) call abort()
+  print *,testObj%test(3,3)
+  if (sum(testObj%test(3,3))/=9) call abort()
 end program bugTest
 
 ! { dg-final { cleanup-modules "bugTestMod" } }
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 149530)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2560,7 +2560,10 @@ gfc_conv_procedure_call (gfc_se * se, gf
 						!= EXPR_CONSTANT)
 			      || (comp && comp->attr.dimension)
 			      || (!comp && sym->attr.dimension));
-  formal = sym->formal;
+  if (comp)
+    formal = comp->formal;
+  else
+    formal = sym->formal;
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
     {
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 149530)
+++ gcc/fortran/module.c	(working copy)
@@ -3439,19 +3439,8 @@ mio_symbol (gfc_symbol *sym)
   mio_symbol_attribute (&sym->attr);
   mio_typespec (&sym->ts);
 
-  /* Contained procedures don't have formal namespaces.  Instead we output the
-     procedure namespace.  The will contain the formal arguments.  */
   if (iomode == IO_OUTPUT)
-    {
-      formal = sym->formal;
-      while (formal && !formal->sym)
-	formal = formal->next;
-
-      if (formal)
-	mio_namespace_ref (&formal->sym->ns);
-      else
-	mio_namespace_ref (&sym->formal_ns);
-    }
+    mio_namespace_ref (&sym->formal_ns);
   else
     {
       mio_namespace_ref (&sym->formal_ns);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 149530)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1239,7 +1239,14 @@ resolve_actual_arglist (gfc_actual_argli
       if (gfc_is_proc_ptr_comp (e, &comp))
 	{
 	  e->ts = comp->ts;
-	  e->expr_type = EXPR_VARIABLE;
+	  if (e->value.compcall.actual == NULL)
+	    e->expr_type = EXPR_VARIABLE;
+	  else
+	    {
+	      if (comp->as != NULL)
+		e->rank = comp->as->rank;
+	      e->expr_type = EXPR_FUNCTION;
+	    }
 	  goto argument_list;
 	}
 
@@ -8993,6 +9000,9 @@ ensure_not_abstract (gfc_symbol* sub, gf
 }
 
 
+static void resolve_symbol (gfc_symbol *sym);
+
+
 /* Resolve the components of a derived type.  */
 
 static gfc_try
@@ -9031,6 +9041,9 @@ resolve_fl_derived (gfc_symbol *sym)
 	    {
 	      gfc_symbol *ifc = c->ts.interface;
 
+	      if (ifc->formal && !ifc->formal_ns)
+		resolve_symbol (ifc);
+
 	      if (ifc->attr.intrinsic)
 		resolve_intrinsic (ifc, &ifc->declared_at);
 
@@ -9832,6 +9845,20 @@ resolve_symbol (gfc_symbol *sym)
   if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
     gfc_resolve (sym->formal_ns);
 
+  /* Make sure the formal namespace is present.  */
+  if (sym->formal && !sym->formal_ns)
+    {
+      gfc_formal_arglist *formal = sym->formal;
+      while (formal && !formal->sym)
+	formal = formal->next;
+
+      if (formal)
+	{
+	  sym->formal_ns = formal->sym->ns;
+	  sym->formal_ns->refs++;
+	}
+    }
+
   /* Check threadprivate restrictions.  */
   if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
       && (!sym->attr.in_common