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

	PR fortran/40176
	* primary.c (gfc_match_varspec): Handle procedure pointer components
	with array return value.
	* resolve.c (resolve_expr_ppc): Ditto.
	(resolve_symbol): Make sure the interface of a procedure pointer has
	been resolved.
	* trans-array.c (gfc_walk_function_expr): Handle procedure pointer
	components with array return value.
	* trans-expr.c (gfc_conv_component_ref,gfc_conv_procedure_call,
	gfc_trans_arrayfunc_assign): Ditto.
	(gfc_trans_pointer_assignment): Handle procedure pointer assignments,
	where the rhs is a dummy argument.
	* trans-types.c (gfc_get_ppc_type,gfc_get_derived_type): Handle
	procedure pointer components with array return value.


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

	PR fortran/40176
	* gfortran.dg/proc_ptr_18.f90: New.
	* gfortran.dg/proc_ptr_19.f90: New.
	* gfortran.dg/proc_ptr_comp_9.f90: New.
	* gfortran.dg/proc_ptr_comp_10.f90: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@147850 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 16 insertions, 5 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index a20d3ae8892..f1f009122ef 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -476,8 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       se->string_length = tmp;
     }
 
-  if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0
-      && c->ts.type != BT_CHARACTER)
+  if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+      || c->attr.proc_pointer)
     se->expr = build_fold_indirect_ref (se->expr);
 }
 
@@ -2396,6 +2396,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   gfc_symbol *fsym;
   stmtblock_t post;
   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+  gfc_component *comp = NULL;
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -2550,11 +2551,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   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
 						!= EXPR_CONSTANT)
-			      || sym->attr.dimension);
+			      || (comp && comp->attr.dimension)
+			      || (!comp && sym->attr.dimension));
   formal = sym->formal;
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
@@ -2825,7 +2828,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       len = cl.backend_decl;
     }
 
-  byref = gfc_return_by_reference (sym);
+  byref = (comp && comp->attr.dimension)
+	  || (!comp && gfc_return_by_reference (sym));
   if (byref)
     {
       if (se->direct_byref)
@@ -4053,6 +4057,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  && expr1->symtree->n.sym->attr.dummy)
 	lse.expr = build_fold_indirect_ref (lse.expr);
 
+      if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+	  && expr2->symtree->n.sym->attr.dummy)
+	rse.expr = build_fold_indirect_ref (rse.expr);
+
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
 
@@ -4284,6 +4292,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_ss *ss;
   gfc_ref * ref;
   bool seen_array_ref;
+  gfc_component *comp = NULL;
 
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
@@ -4343,8 +4352,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
      functions.  */
+  is_proc_ptr_comp(expr2, &comp);
   gcc_assert (expr2->value.function.isym
-	      || (gfc_return_by_reference (expr2->value.function.esym)
+	      || (comp && comp->attr.dimension)
+	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
 	      && expr2->value.function.esym->result->attr.dimension));
 
   ss = gfc_walk_expr (expr1);