re PR fortran/45170 ([F2003] allocatable character lengths)

2011-01-28  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/45170
	PR fortran/35810
	PR fortran/47350
	* interface.c (compare_actual_formal): An allocatable or pointer
	deferred length actual is only allowed if the formal argument
	is also deferred length. Clean up whitespace.
	* trans-expr.c (gfc_conv_procedure_call): Pass string length for
	deferred character length formal arguments by reference. Do the
	same for function results.
	(gfc_trans_pointer_assignment): Do not do runtime check of lhs
	and rhs character lengths, if deferred length lhs.  In this case
	set the lhs character length to that of the rhs.
	(gfc_conv_string_parameter): Remove assert that string length is
	an integer type.
	(is_scalar_reallocatable_lhs): New function.
	(alloc_scalar_allocatable_for_assignment): New function.
	(gfc_trans_assignment_1): Call above new function. If the rhs is
	a deferred character length itself, makes ure that the function
	is called before reallocation, so that the length is available.
	(gfc_trans_asssignment): Remove error about assignment to
	deferred length character variables.
	* gfortran.texi : Update entry about (re)allocation on
	assignment.
	* trans-stmt.c (gfc_trans_allocate): Add code to handle deferred
	length character variables.
	* module.c (mio_typespec): Transfer deferred characteristic.
	* trans-types.c (gfc_get_function_type): New code to generate
	hidden typelist, so that those character lengths that are
	passed by reference get the right type.
	* resolve.c (resolve_contained_fntype): Supress error for
	deferred character length functions.
	(resolve_function, resolve_fl_procedure) The same.
	(check_symbols): Remove the error that support for
	entity with deferred type parameter is not yet implemented.
	(resolve_fl_derived): The same.
	match.c (alloc_opt_list): Allow MOLD for deferred length object.
	* trans-decl.c (gfc_get_symbol_decl): For deferred character
	length dummies, generate a local variable for string length.
	(create_function_arglist): Hidden length can be a pointer.
	(gfc_trans_deferred_vars): For deferred character length
	results and dummies, assign the string length to the local
	variable from the hidden argument on entry and the other way
	round on exit, as appropriate.

2011-01-28  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/45170
	PR fortran/35810
	PR fortran/47350
	* gfortran.dg/realloc_on_assign_3.f03: New test.
	* gfortran.dg/realloc_on_assign_4.f03: New test.
	* gfortran.dg/realloc_on_assign_5.f90: New test.
	* gfortran.dg/allocatable_function_5.f90: New test.
	* gfortran.dg/allocate_deferred_char_scalar_1.f90: New test.
	* gfortran.dg/deferred_type_param_2.f90: Remove two "not yet
	implemented" dg-errors.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r169356

1 files changed, 186 insertions, 13 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index ec1e848..9bbe791 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3322,6 +3322,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
         }
       end_pointer_check:
 
+      /* Deferred length dummies pass the character length by reference
+	 so that the value can be returned.  */
+      if (parmse.string_length && fsym && fsym->ts.deferred)
+	{
+	  tmp = parmse.string_length;
+	  if (TREE_CODE (tmp) != VAR_DECL)
+	    tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
+	  parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
 
       /* Character strings are passed as two parameters, a length and a
          pointer - except for Bind(c) which only passes the pointer.  */
@@ -3349,7 +3358,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	     we take the character length of the first argument for the result.
 	     For dummies, we have to look through the formal argument list for
 	     this function and use the character length found there.*/
-	  if (!sym->attr.dummy)
+	  if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
+	    cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
+	  else if (!sym->attr.dummy)
 	    cl.backend_decl = VEC_index (tree, stringargs, 0);
 	  else
 	    {
@@ -3534,6 +3545,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  VEC_safe_push (tree, gc, retargs, var);
 	}
 
+      if (ts.type == BT_CHARACTER && ts.deferred
+	    && (sym->attr.allocatable || sym->attr.pointer))
+	{
+	  tmp = len;
+	  if (TREE_CODE (tmp) != VAR_DECL)
+	    tmp = gfc_evaluate_now (len, &se->pre);
+	  len = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
       /* Add the string length to the argument list.  */
       if (ts.type == BT_CHARACTER)
 	VEC_safe_push (tree, gc, retargs, len);
@@ -3642,7 +3662,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      else
 	        se->expr = var;
 
-	      se->string_length = len;
+	      if (!ts.deferred)
+		se->string_length = len;
+	      else if (sym->attr.allocatable || sym->attr.pointer)
+		se->string_length = cl.backend_decl;
 	    }
 	  else
 	    {
@@ -4919,8 +4942,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_add_block_to_block (&block, &rse.pre);
 
       /* Check character lengths if character expression.  The test is only
-	 really added if -fbounds-check is enabled.  */
+	 really added if -fbounds-check is enabled.  Exclude deferred
+	 character length lefthand sides.  */
       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+	  && !(expr1->ts.deferred
+			&& (TREE_CODE (lse.string_length) == VAR_DECL))
 	  && !expr1->symtree->n.sym->attr.proc_pointer
 	  && !gfc_is_proc_ptr_comp (expr1, NULL))
 	{
@@ -4931,6 +4957,17 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 				       &block);
 	}
 
+      /* The assignment to an deferred character length sets the string
+	 length to that of the rhs.  */
+      if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
+	{
+	  if (expr2->expr_type != EXPR_NULL)
+	    gfc_add_modify (&block, lse.string_length, rse.string_length);
+	  else
+	    gfc_add_modify (&block, lse.string_length,
+			    build_int_cst (gfc_charlen_type_node, 0));
+	}
+
       gfc_add_modify (&block, lse.expr,
 			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
 
@@ -5206,8 +5243,6 @@ gfc_conv_string_parameter (gfc_se * se)
     }
 
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
-  gcc_assert (se->string_length
-	  && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
 }
 
 
@@ -5792,6 +5827,136 @@ expr_is_variable (gfc_expr *expr)
 }
 
 
+/* Is the lhs OK for automatic reallocation?  */
+
+static bool
+is_scalar_reallocatable_lhs (gfc_expr *expr)
+{
+  gfc_ref * ref;
+
+  /* An allocatable variable with no reference.  */
+  if (expr->symtree->n.sym->attr.allocatable
+	&& !expr->ref)
+    return true;
+
+  /* All that can be left are allocatable components.  */
+  if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+	&& expr->symtree->n.sym->ts.type != BT_CLASS)
+	|| !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+    return false;
+
+  /* Find an allocatable component ref last.  */
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT
+	  && !ref->next
+	  && ref->u.c.component->attr.allocatable)
+      return true;
+
+  return false;
+}
+
+
+/* Allocate or reallocate scalar lhs, as necessary.  */
+
+static void
+alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
+					 tree string_length,
+					 gfc_expr *expr1,
+					 gfc_expr *expr2)
+
+{
+  tree cond;
+  tree tmp;
+  tree size;
+  tree size_in_bytes;
+  tree jump_label1;
+  tree jump_label2;
+  gfc_se lse;
+
+  if (!expr1 || expr1->rank)
+    return;
+
+  if (!expr2 || expr2->rank)
+    return;
+
+  /* Since this is a scalar lhs, we can afford to do this.  That is,
+     there is no risk of side effects being repeated.  */
+  gfc_init_se (&lse, NULL);
+  lse.want_pointer = 1;
+  gfc_conv_expr (&lse, expr1);
+  
+  jump_label1 = gfc_build_label_decl (NULL_TREE);
+  jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+  /* Do the allocation if the lhs is NULL. Otherwise go to label 1.  */
+  tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  lse.expr, tmp);
+  tmp = build3_v (COND_EXPR, cond,
+		  build1_v (GOTO_EXPR, jump_label1),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      /* Use the rhs string length and the lhs element size.  */
+      size = string_length;
+      tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
+      tmp = TYPE_SIZE_UNIT (tmp);
+      size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (tmp), size));
+    }
+  else
+    {
+      /* Otherwise use the length in bytes of the rhs.  */
+      size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+      size_in_bytes = size;
+    }
+
+  tmp = build_call_expr_loc (input_location,
+			     built_in_decls[BUILT_IN_MALLOC], 1,
+			     size_in_bytes);
+  tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+  gfc_add_modify (block, lse.expr, tmp);
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      /* Deferred characters need checking for lhs and rhs string
+	 length.  Other deferred parameter variables will have to
+	 come here too.  */
+      tmp = build1_v (GOTO_EXPR, jump_label2);
+      gfc_add_expr_to_block (block, tmp);
+    }
+  tmp = build1_v (LABEL_EXPR, jump_label1);
+  gfc_add_expr_to_block (block, tmp);
+
+  /* For a deferred length character, reallocate if lengths of lhs and
+     rhs are different.  */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			      expr1->ts.u.cl->backend_decl, size);
+      /* Jump past the realloc if the lengths are the same.  */
+      tmp = build3_v (COND_EXPR, cond,
+		      build1_v (GOTO_EXPR, jump_label2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (block, tmp);
+      tmp = build_call_expr_loc (input_location,
+				 built_in_decls[BUILT_IN_REALLOC], 2,
+				 fold_convert (pvoid_type_node, lse.expr),
+				 size_in_bytes);
+      tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+      gfc_add_modify (block, lse.expr, tmp);
+      tmp = build1_v (LABEL_EXPR, jump_label2);
+      gfc_add_expr_to_block (block, tmp);
+
+      /* Update the lhs character length.  */
+      size = string_length;
+      gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+    }
+}
+
+
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
    init_flag indicates initialization expressions and dealloc that no
@@ -5929,6 +6094,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       gfc_add_expr_to_block (&loop.post, tmp);
     }
 
+  /* For a deferred character length function, the function call must
+     happen before the (re)allocation of the lhs, otherwise the character
+     length of the result is not known.  */
+  if (gfc_option.flag_realloc_lhs
+	&& expr2->expr_type == EXPR_FUNCTION
+	&& expr2->ts.type == BT_CHARACTER
+	&& expr2->ts.deferred)
+    gfc_add_block_to_block (&block, &rse.pre);
+
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
 				 l_is_temp || init_flag,
 				 expr_is_variable (expr2) || scalar_to_array,
@@ -5937,6 +6111,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 
   if (lss == gfc_ss_terminator)
     {
+      /* F2003: Add the code for reallocation on assignment.  */
+      if (gfc_option.flag_realloc_lhs
+	    && is_scalar_reallocatable_lhs (expr1))
+	alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
+						 expr1, expr2);
+
       /* Use the scalar assignment as is.  */
       gfc_add_block_to_block (&block, &body);
     }
@@ -5972,7 +6152,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  gfc_add_expr_to_block (&body, tmp);
 	}
 
-      /* Allocate or reallocate lhs of allocatable array.  */
+      /* F2003: Allocate or reallocate lhs of allocatable array.  */
       if (gfc_option.flag_realloc_lhs
 	    && gfc_is_reallocatable_lhs (expr1)
 	    && !gfc_expr_attr (expr1).codimension
@@ -6042,13 +6222,6 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 {
   tree tmp;
 
-  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
-    {
-      gfc_error ("Assignment to deferred-length character variable at %L "
-		 "not implemented", &expr1->where);
-      return NULL_TREE;
-    }
-
   /* Special case a single function returning an array.  */
   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
     {