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

gcc/fortran/ChangeLog

+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 Schlter  <tobi@gcc.gnu.org>
 
 	* trans-stmt.c (gfc_trans_do): Add a few missing folds.

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.  */

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)

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

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)

gcc/testsuite/ChangeLog

+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.
+
 2009-08-21  Jakub Jelinek  <jakub@redhat.com>
 
 	PR c++/41131

gcc/testsuite/gfortran.dg/proc_ptr_23.f90

+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+character(len=5) :: str
+procedure(character(len=5)), pointer :: pp
+pp => abc
+print *,pp()
+str = pp()
+if (str/='abcde') call abort()
+contains
+ function abc()
+  character(len=5) :: abc
+  abc = 'abcde'
+ end function abc
+end
+

gcc/testsuite/gfortran.dg/proc_ptr_comp_15.f90

+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module m
+ type :: t
+ procedure(character(len=5)), pointer, nopass :: ptr
+ end type
+contains
+ function abc()
+  character(len=5) :: abc
+  abc = 'abcde'
+ end function abc
+end module m
+
+use m
+ type(t) :: x
+ character(len=5) :: str
+ x%ptr => abc
+ print *,x%ptr()
+ str = x%ptr()
+ if (str/='abcde') call abort()
+end
+
+! { dg-final { cleanup-modules "m" } }
+

gcc/testsuite/gfortran.dg/proc_ptr_comp_16.f90

+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+ type :: t
+  procedure(abc), pointer, nopass :: ptr
+ end type
+contains
+ function abc(i)
+  integer :: i
+  character(len=i) :: abc
+  abc = 'abcde'
+ end function abc
+end module m
+
+use m
+ type(t) :: x
+ character(len=4) :: str
+ x%ptr => abc
+ print *,x%ptr(4)
+ if (x%ptr(4)/='abcd') call abort
+ str = x%ptr(3)
+ if (str/='abc') call abort()
+end
+
+! { dg-final { cleanup-modules "m" } }
+

gcc/testsuite/gfortran.dg/proc_ptr_comp_17.f90

+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+ type :: t
+ procedure(abc), pointer, nopass :: ptr
+ end type
+contains
+ function abc(arg)
+  character(len=5),pointer :: abc
+  character(len=5),target :: arg
+  abc => arg
+ end function abc
+end module m
+
+use m
+ type(t) :: x
+ character(len=5) :: str = 'abcde'
+ character(len=5), pointer :: strptr
+ x%ptr => abc
+ print *,x%ptr(str)
+ strptr => x%ptr(str)
+ if (strptr/='abcde') call abort()
+ str = 'fghij'
+ if (strptr/='fghij') call abort()
+end
+
+! { dg-final { cleanup-modules "m" } }
+