[Patch, Fortran, F03] PR 41106: Procedure Pointers with CHARACTER results

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

Hi all,

here is another patch concerning procedure pointers and procedure
pointer components, fixing the cases where those have CHARACTER return
values.
Since character return values are a bit of a special case (being
returned by reference etc), quite a number of adjustments had to be
made for PPCs, mostly in gfc_conv_procedure_call. One of the test
cases was found by Tobias when reviewing my patch for PR 40870, and I
added a few more (e.g. with non-constant character-lengths or
character-pointer return values).

Regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2009-08-20  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41106
	* primary.c (gfc_variable_attr): Make it work also on EXPR_FUNCTION.
	(gfc_expr_attr): Use gfc_variable_attr for procedure pointer components.
	* resolve.c (resolve_fl_derived): Handle CHARACTER-valued procedure
	pointer components.
	* trans-expr.c (gfc_conv_component_ref): Ditto.
	(gfc_conv_variable): Ditto.
	(gfc_conv_procedure_call): Ditto.
	(gfc_trans_pointer_assignment): Ditto.
	* trans-types.c (gfc_get_derived_type): Ditto.

2009-08-20  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41106
	* gfortran.dg/proc_ptr_23.f90: New.
	* gfortran.dg/proc_ptr_comp_15.f90: New.
	* gfortran.dg/proc_ptr_comp_16.f90: New.
	* gfortran.dg/proc_ptr_comp_17.f90: New.

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 150962)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -474,7 +474,7 @@ gfc_conv_component_ref (gfc_se * se, gfc
 
   se->expr = tmp;
 
-  if (c->ts.type == BT_CHARACTER)
+  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
     {
       tmp = c->ts.u.cl->backend_decl;
       /* Components must always be constant length.  */
@@ -714,7 +714,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr
      separately.  */
   if (se->want_pointer)
     {
-      if (expr->ts.type == BT_CHARACTER)
+      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
 	gfc_conv_string_parameter (se);
       else 
 	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
@@ -2913,12 +2913,16 @@ gfc_conv_procedure_call (gfc_se * se, gf
     }
   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
 
-  ts = sym->ts;
+  if (comp)
+    ts = comp->ts;
+  else
+   ts = sym->ts;
+
   if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
     se->string_length = build_int_cst (gfc_charlen_type_node, 1);
   else if (ts.type == BT_CHARACTER)
     {
-      if (sym->ts.u.cl->length == NULL)
+      if (ts.u.cl->length == NULL)
 	{
 	  /* Assumed character length results are not allowed by 5.1.1.5 of the
 	     standard and are trapped in resolve.c; except in the case of SPREAD
@@ -2943,9 +2947,9 @@ gfc_conv_procedure_call (gfc_se * se, gf
 	  /* Calculate the length of the returned string.  */
 	  gfc_init_se (&parmse, NULL);
 	  if (need_interface_mapping)
-	    gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.u.cl->length);
+	    gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
 	  else
-	    gfc_conv_expr (&parmse, sym->ts.u.cl->length);
+	    gfc_conv_expr (&parmse, ts.u.cl->length);
 	  gfc_add_block_to_block (&se->pre, &parmse.pre);
 	  gfc_add_block_to_block (&se->post, &parmse.post);
 	  
@@ -2963,7 +2967,7 @@ gfc_conv_procedure_call (gfc_se * se, gf
       len = cl.backend_decl;
     }
 
-  byref = (comp && comp->attr.dimension)
+  byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
 	  || (!comp && gfc_return_by_reference (sym));
   if (byref)
     {
@@ -3004,7 +3008,7 @@ gfc_conv_procedure_call (gfc_se * se, gf
 	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
 	  retargs = gfc_chainon_list (retargs, tmp);
 	}
-      else if (sym->result->attr.dimension)
+      else if (!comp && sym->result->attr.dimension)
 	{
 	  gcc_assert (se->loop && info);
 
@@ -3036,7 +3040,8 @@ gfc_conv_procedure_call (gfc_se * se, gf
 
 	  /* Return an address to a char[0:len-1]* temporary for
 	     character pointers.  */
-	  if (sym->attr.pointer || sym->attr.allocatable)
+	  if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+	       || (comp && (comp->attr.pointer || comp->attr.allocatable)))
 	    {
 	      var = gfc_create_var (type, "pstr");
 
@@ -3148,12 +3153,12 @@ gfc_conv_procedure_call (gfc_se * se, gf
 	      /* Bundle in the string length.  */
 	      se->string_length = len;
 	    }
-	  else if (sym->ts.type == BT_CHARACTER)
+	  else if (ts.type == BT_CHARACTER)
 	    {
 	      /* Dereference for character pointer results.  */
-	      if (sym->attr.pointer || sym->attr.allocatable)
-		se->expr = build_fold_indirect_ref_loc (input_location,
-						    var);
+	      if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+		  || (comp && (comp->attr.pointer || comp->attr.allocatable)))
+		se->expr = build_fold_indirect_ref_loc (input_location, var);
 	      else
 	        se->expr = var;
 
@@ -3161,9 +3166,8 @@ gfc_conv_procedure_call (gfc_se * se, gf
 	    }
 	  else
 	    {
-	      gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
-	      se->expr = build_fold_indirect_ref_loc (input_location,
-						  var);
+	      gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+	      se->expr = build_fold_indirect_ref_loc (input_location, var);
 	    }
 	}
     }
@@ -4237,7 +4241,9 @@ gfc_trans_pointer_assignment (gfc_expr *
 
       /* Check character lengths if character expression.  The test is only
 	 really added if -fbounds-check is enabled.  */
-      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+	  && !expr1->symtree->n.sym->attr.proc_pointer
+	  && !gfc_is_proc_ptr_comp (expr1, NULL))
 	{
 	  gcc_assert (expr2->ts.type == BT_CHARACTER);
 	  gcc_assert (lse.string_length && rse.string_length);
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 150962)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -2134,12 +2134,11 @@ gfc_get_derived_type (gfc_symbol * deriv
 						    PACKED_STATIC,
 						    !c->attr.target);
 	}
-      else if (c->attr.pointer)
+      else if (c->attr.pointer && !c->attr.proc_pointer)
 	field_type = build_pointer_type (field_type);
 
       field = gfc_add_field_to_struct (&fieldlist, typenode,
-				       get_identifier (c->name),
-				       field_type);
+				       get_identifier (c->name), field_type);
       if (c->loc.lb)
 	gfc_set_decl_location (field, &c->loc);
       else if (derived->declared_at.lb)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 150962)
+++ gcc/fortran/resolve.c	(working copy)
@@ -9604,7 +9604,7 @@ resolve_fl_derived (gfc_symbol *sym)
 	  return FAILURE;
 	}
 
-      if (c->ts.type == BT_CHARACTER)
+      if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
 	{
 	 if (c->ts.u.cl->length == NULL
 	     || (resolve_charlen (c->ts.u.cl) == FAILURE)
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 150962)
+++ gcc/fortran/primary.c	(working copy)
@@ -1938,7 +1938,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
   symbol_attribute attr;
   gfc_ref *ref;
 
-  if (expr->expr_type != EXPR_VARIABLE)
+  if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
 
   ref = expr->ref;
@@ -2032,6 +2032,8 @@ gfc_expr_attr (gfc_expr *e)
 
       if (e->value.function.esym != NULL)
 	attr = e->value.function.esym->result->attr;
+      else
+	attr = gfc_variable_attr (e, NULL);
 
       /* TODO: NULL() returns pointers.  May have to take care of this
 	 here.  */

Attachment: proc_ptr_23.f90
Description: Binary data

Attachment: proc_ptr_comp_15.f90
Description: Binary data

Attachment: proc_ptr_comp_16.f90
Description: Binary data

Attachment: proc_ptr_comp_17.f90
Description: Binary data