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, 63 insertions, 3 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 8781d0e723c..161b309e00f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1,5 +1,6 @@
 /* Statement translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -4507,14 +4508,73 @@ gfc_trans_allocate (gfc_code * code)
 	      else
 		memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
 	    }
+	  else if (al->expr->ts.type == BT_CHARACTER
+		     && al->expr->ts.deferred && code->expr3)
+	    {
+	      if (!code->expr3->ts.u.cl->backend_decl)
+		{
+		  /* Convert and use the length expression.  */
+		  gfc_se se_sz;
+		  gfc_init_se (&se_sz, NULL);
+		  if (code->expr3->expr_type == EXPR_VARIABLE
+			|| code->expr3->expr_type == EXPR_CONSTANT)
+		    {
+		      gfc_conv_expr (&se_sz, code->expr3);
+		      memsz = se_sz.string_length;
+		    }
+		  else
+		    {
+		      gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+		      memsz = se_sz.expr;
+		    }
+		  if (TREE_CODE (se.string_length) == VAR_DECL)
+                    gfc_add_modify (&block, se.string_length,
+				    fold_convert (TREE_TYPE (se.string_length),
+						  memsz));
+		}
+	      else
+		/* Otherwise use the stored string length.  */
+		memsz = code->expr3->ts.u.cl->backend_decl;
+	      tmp = al->expr->ts.u.cl->backend_decl;
+
+	      /* Store the string length.  */
+	      if (tmp && TREE_CODE (tmp) == VAR_DECL)
+		gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp),
+				memsz));
+
+	      /* Convert to size in bytes, using the character KIND.  */
+	      tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
+	      tmp = TYPE_SIZE_UNIT (tmp);
+	      memsz = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (tmp), memsz));
+	    }
 	  else if (code->ext.alloc.ts.type != BT_UNKNOWN)
 	    memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
 	  else
 	    memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
 
 	  if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
-	    memsz = se.string_length;
-
+	    {
+	      if (expr->ts.deferred)
+		{
+		  gfc_se se_sz;
+		  gfc_init_se (&se_sz, NULL);
+		  gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+		  memsz = se_sz.expr;
+                  gfc_add_modify (&block, se.string_length,
+				  fold_convert (TREE_TYPE (se.string_length),
+						memsz));
+		}
+	      else
+		memsz = se.string_length;
+	      /* Convert to size in bytes, using the character KIND.  */
+	      tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
+	      tmp = TYPE_SIZE_UNIT (tmp);
+	      memsz = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (tmp), memsz));
+	    }
 	  /* Allocate - for non-pointers with re-alloc checking.  */
 	  {
 	    gfc_ref *ref;