re PR fortran/41106 ([F03] Procedure Pointers with CHARACTER results)

2009-08-21  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-21  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.

From-SVN: r150987

5 files changed, 61 insertions, 32 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6fde5a4..53a9d6d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2009-08-21  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  Tobias Schlüter  <tobi@gcc.gnu.org>
 
 	* trans-stmt.c (gfc_trans_do): Add a few missing folds.
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index e0021c5..0a917f7 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1938,7 +1938,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   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.  */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3782bb2..411e2c8 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c2c1f0fb..3f5e76d 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -474,7 +474,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
 
   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 * 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, gfc_symbol * sym,
 
   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, gfc_symbol * sym,
     }
   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, gfc_symbol * sym,
 	  /* 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, gfc_symbol * sym,
       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, gfc_symbol * sym,
 	  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, gfc_symbol * sym,
 
 	  /* 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, gfc_symbol * sym,
 	      /* 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, gfc_symbol * sym,
 	    }
 	  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 * expr1, gfc_expr * expr2)
 
       /* 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);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 4a29399..454a155 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2134,12 +2134,11 @@ gfc_get_derived_type (gfc_symbol * derived)
 						    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)