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

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

> 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).

Before people start reviewing this, a small update.

I forgot two things concerning CHARACTER results with non-const lengths:

1) When copying the interface to the PP component, one needs to take
care of replacing symbols (which are formal args of the PPC) in the
length expr, so that the ones from the PPC's formal_ns are used (and
not from the interface's formal_ns). This was a TODO item in
resolve_fl_derived, which is now fixed.

2) The arguments must be remapped in this case.
'need_interface_mapping' was not set correctly in
'gfc_conv_procedure_call'. This works now.

The testcase 'proc_ptr_comp_16' was updated to probe both of these issues.

Regtest is running. Ok if successful?

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 150967)
+++ 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);
@@ -2577,16 +2577,25 @@ gfc_conv_procedure_call (gfc_se * se, gf
 
   gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
-  need_interface_mapping = ((sym->ts.type == BT_CHARACTER
-				  && sym->ts.u.cl->length
-				  && sym->ts.u.cl->length->expr_type
-						!= EXPR_CONSTANT)
-			      || (comp && comp->attr.dimension)
-			      || (!comp && sym->attr.dimension));
-  if (comp)
-    formal = comp->formal;
+  if (!comp)
+    {
+      formal = sym->formal;
+      need_interface_mapping = sym->attr.dimension ||
+			       (sym->ts.type == BT_CHARACTER
+				&& sym->ts.u.cl->length
+				&& sym->ts.u.cl->length->expr_type
+				   != EXPR_CONSTANT);
+    }
   else
-    formal = sym->formal;
+    {
+      formal = comp->formal;
+      need_interface_mapping = comp->attr.dimension ||
+			       (comp->ts.type == BT_CHARACTER
+				&& comp->ts.u.cl->length
+				&& comp->ts.u.cl->length->expr_type
+				   != EXPR_CONSTANT);
+    }
+
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
     {
@@ -2913,12 +2922,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 +2956,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 +2976,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 +3017,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 +3049,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 +3162,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 +3175,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 +4250,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 150967)
+++ 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 150967)
+++ gcc/fortran/resolve.c	(working copy)
@@ -9476,7 +9476,7 @@ resolve_fl_derived (gfc_symbol *sym)
 	      if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
 		{
 		  c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
-		  /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/
+		  gfc_expr_replace_comp (c->ts.u.cl->length, c);
 		}
 	    }
 	  else if (c->ts.interface->name[0] != '\0')
@@ -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 150967)
+++ 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_comp_16.f90
Description: Binary data