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

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

> I think the proper fix for this problem would be:
>
> Index: gcc/fortran/primary.c
> ===================================================================
> --- gcc/fortran/primary.c ? ? ? (revision 149230)
> +++ gcc/fortran/primary.c ? ? ? (working copy)
> @@ -1727,7 +1727,10 @@ gfc_match_varspec (gfc_expr *primary, in
>
> ? gfc_gobble_whitespace ();
> ? if ((equiv_flag && gfc_peek_ascii_char () == '(')
> - ? ? ?|| (sym->attr.dimension && !sym->attr.proc_pointer))
> + ? ? ?|| (sym->attr.dimension && !sym->attr.proc_pointer
> + ? ? ? ? && !is_proc_ptr_comp (primary, NULL)
> + ? ? ? ? && !(gfc_matching_procptr_assignment
> + ? ? ? ? ? ? ?&& sym->attr.flavor == FL_PROCEDURE)))
> ? ? {
> ? ? ? /* In EQUIVALENCE, we don't know yet whether we are seeing
> ? ? ? ? an array, character variable or array of character
>
> At least this fixes the proc-pointer assignments in comment #2 and #4.
> Comment #4 runs fine then, but calling the PPC in comment #2 still
> gives an ICE. I'm working on it ...

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.
Nonetheless I would like to get this committed first and take care of
the rest later, since the patch has already gotten quite large, and
the remaining problems (concerning formal_ns) are rather nasty.

The patch basically implements support for array-valued PPCs, which
was not included in my initial PPC patch. It is regtested on 149259.
Ok for trunk?

Cheers,
Janus


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

	PR fortran/40646
	* expr.c (replace_comp,gfc_expr_replace_comp): New functions, analogous
	to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components
	instead of symbols.
	* gfortran.h (gfc_expr_replace_comp): New prototype.
	* primary.c (gfc_match_varspec): Handle array-valued procedure pointers
	and procedure pointer components.
	* resolve.c (resolve_fl_derived): Correctly handle interfaces with
	RESULT statement, and handle array-valued procedure pointer components.
	* trans-decl.c (gfc_get_symbol_decl): Security check for presence of
	ns->proc_name.
	* trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure
	pointer components.
	(gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead
	make a copy of it.
	* trans-io.c (gfc_trans_transfer): Handle array-valued procedure
	pointer components.


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

	PR fortran/40646
	* gfortran.dg/proc_ptr_21.f90: New.
	* gfortran.dg/proc_ptr_comp_12.f90: New.

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 149259)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2526,7 +2526,9 @@ gfc_conv_procedure_call (gfc_se * se, gf
 	  return 0;
 	}
     }
-  
+
+  is_proc_ptr_comp (expr, &comp);
+
   if (se->ss != NULL)
     {
       if (!sym->attr.elemental)
@@ -2534,8 +2536,9 @@ gfc_conv_procedure_call (gfc_se * se, gf
 	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
           if (se->ss->useflags)
             {
-              gcc_assert (gfc_return_by_reference (sym)
-                      && sym->result->attr.dimension);
+	      gcc_assert ((!comp && gfc_return_by_reference (sym)
+			   && sym->result->attr.dimension)
+			  || (comp && comp->attr.dimension));
               gcc_assert (se->loop != NULL);
 
               /* Access the previously obtained result.  */
@@ -2551,7 +2554,6 @@ gfc_conv_procedure_call (gfc_se * se, gf
 
   gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
-  is_proc_ptr_comp (expr, &comp);
   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
 				  && sym->ts.cl->length
 				  && sym->ts.cl->length->expr_type
@@ -2898,6 +2900,30 @@ gfc_conv_procedure_call (gfc_se * se, gf
 
 	  retargs = gfc_chainon_list (retargs, se->expr);
 	}
+      else if (comp && comp->attr.dimension)
+	{
+	  gcc_assert (se->loop && info);
+
+	  /* Set the type of the array.  */
+	  tmp = gfc_typenode_for_spec (&comp->ts);
+	  info->dimen = se->loop->dimen;
+
+	  /* Evaluate the bounds of the result, if known.  */
+	  gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+
+	  /* Create a temporary to store the result.  In case the function
+	     returns a pointer, the temporary will be a shallow copy and
+	     mustn't be deallocated.  */
+	  callee_alloc = comp->attr.allocatable || comp->attr.pointer;
+	  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
+				       NULL_TREE, false, !comp->attr.pointer,
+				       callee_alloc, &se->ss->expr->where);
+
+	  /* Pass the temporary as the first argument.  */
+	  tmp = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  retargs = gfc_chainon_list (retargs, tmp);
+	}
       else if (sym->result->attr.dimension)
 	{
 	  gcc_assert (se->loop && info);
@@ -3025,7 +3051,7 @@ gfc_conv_procedure_call (gfc_se * se, gf
 
       if (!se->direct_byref)
 	{
-	  if (sym->attr.dimension)
+	  if (sym->attr.dimension || (comp && comp->attr.dimension))
 	    {
 	      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
 		{
@@ -3382,9 +3408,11 @@ tree
 gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
 {
   gfc_se comp_se;
+  gfc_expr *e2;
   gfc_init_se (&comp_se, NULL);
-  e->expr_type = EXPR_VARIABLE;
-  gfc_conv_expr (&comp_se, e);
+  e2 = gfc_copy_expr (e);
+  e2->expr_type = EXPR_VARIABLE;
+  gfc_conv_expr (&comp_se, e2);
   comp_se.expr = build_fold_addr_expr (comp_se.expr);
   return gfc_evaluate_now (comp_se.expr, &se->pre);  
 }
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 149259)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2538,6 +2538,7 @@ bool gfc_traverse_expr (gfc_expr *, gfc_
 void gfc_expr_set_symbols_referenced (gfc_expr *);
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
+void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
 
 bool is_proc_ptr_comp (gfc_expr *, gfc_component **);
 
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 149259)
+++ gcc/fortran/expr.c	(working copy)
@@ -3672,3 +3672,33 @@ gfc_expr_replace_symbols (gfc_expr *expr
 {
   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
 }
+
+static bool
+replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+  gfc_component *comp;
+  comp = (gfc_component *)sym;
+  if ((expr->expr_type == EXPR_VARIABLE 
+       || (expr->expr_type == EXPR_FUNCTION
+	   && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+      && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
+    {
+      gfc_symtree *stree;
+      gfc_namespace *ns = comp->formal_ns;
+      /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+	 the symtree rather than create a new one (and probably fail later).  */
+      stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+		      		expr->symtree->n.sym->name);
+      gcc_assert (stree);
+      stree->n.sym->attr = expr->symtree->n.sym->attr;
+      expr->symtree = stree;
+    }
+  return false;
+}
+
+void
+gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
+{
+  gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
+}
+
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 149259)
+++ gcc/fortran/resolve.c	(working copy)
@@ -9034,32 +9034,40 @@ resolve_fl_derived (gfc_symbol *sym)
 		resolve_intrinsic (ifc, &ifc->declared_at);
 
 	      if (ifc->result)
-		c->ts = ifc->result->ts;
-	      else   
-		c->ts = ifc->ts;
+		{
+		  c->ts = ifc->result->ts;
+		  c->attr.allocatable = ifc->result->attr.allocatable;
+		  c->attr.pointer = ifc->result->attr.pointer;
+		  c->attr.dimension = ifc->result->attr.dimension;
+		  c->as = gfc_copy_array_spec (ifc->result->as);
+		}
+	      else
+		{   
+		  c->ts = ifc->ts;
+		  c->attr.allocatable = ifc->attr.allocatable;
+		  c->attr.pointer = ifc->attr.pointer;
+		  c->attr.dimension = ifc->attr.dimension;
+		  c->as = gfc_copy_array_spec (ifc->as);
+		}
 	      c->ts.interface = ifc;
 	      c->attr.function = ifc->attr.function;
 	      c->attr.subroutine = ifc->attr.subroutine;
 	      gfc_copy_formal_args_ppc (c, ifc);
 
-	      c->attr.allocatable = ifc->attr.allocatable;
-	      c->attr.pointer = ifc->attr.pointer;
 	      c->attr.pure = ifc->attr.pure;
 	      c->attr.elemental = ifc->attr.elemental;
-	      c->attr.dimension = ifc->attr.dimension;
 	      c->attr.recursive = ifc->attr.recursive;
 	      c->attr.always_explicit = ifc->attr.always_explicit;
-	      /* Copy array spec.  */
-	      c->as = gfc_copy_array_spec (ifc->as);
-	      /* TODO: if (c->as)
+	      /* Replace symbols in array spec.  */
+	      if (c->as)
 		{
 		  int i;
 		  for (i = 0; i < c->as->rank; i++)
 		    {
-		      gfc_expr_replace_symbols (c->as->lower[i], c);
-		      gfc_expr_replace_symbols (c->as->upper[i], c);
+		      gfc_expr_replace_comp (c->as->lower[i], c);
+		      gfc_expr_replace_comp (c->as->upper[i], c);
 		    }
-	        }*/
+	        }
 	      /* Copy char length.  */
 	      if (ifc->ts.cl)
 		{
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c	(revision 149259)
+++ gcc/fortran/trans-io.c	(working copy)
@@ -2165,7 +2165,7 @@ gfc_trans_transfer (gfc_code * code)
       /* Transfer an array. If it is an array of an intrinsic
 	 type, pass the descriptor to the library.  Otherwise
 	 scalarize the transfer.  */
-      if (expr->ref)
+      if (expr->ref && !is_proc_ptr_comp (expr, NULL))
 	{
 	  for (ref = expr->ref; ref && ref->type != REF_ARRAY;
 		 ref = ref->next);
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 149259)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -1015,7 +1015,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 		|| sym->attr.use_assoc
 		|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
 
-  if (sym->ns && sym->ns->proc_name->attr.function)
+  if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
     byref = gfc_return_by_reference (sym->ns->proc_name);
   else
     byref = 0;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 149259)
+++ gcc/fortran/primary.c	(working copy)
@@ -1727,7 +1727,10 @@ gfc_match_varspec (gfc_expr *primary, in
 
   gfc_gobble_whitespace ();
   if ((equiv_flag && gfc_peek_ascii_char () == '(')
-      || (sym->attr.dimension && !sym->attr.proc_pointer))
+      || (sym->attr.dimension && !sym->attr.proc_pointer
+	  && !is_proc_ptr_comp (primary, NULL)
+	  && !(gfc_matching_procptr_assignment
+	       && sym->attr.flavor == FL_PROCEDURE)))
     {
       /* In EQUIVALENCE, we don't know yet whether we are seeing
 	 an array, character variable or array of character

Attachment: proc_ptr_21.f90
Description: Binary data

Attachment: proc_ptr_comp_12.f90
Description: Binary data