Patchwork [fortran] F2003 - Scalar (re)allocation on assignment and deferred character length scalars.

login
register
mail settings
Submitter Paul Richard Thomas
Date Jan. 27, 2011, 8:45 p.m.
Message ID <AANLkTimxUfvUHPB=LFZEjOCz6Jbu6TMbjtFow-zAZVDN@mail.gmail.com>
Download mbox | patch
Permalink /patch/80736/
State New
Headers show

Comments

Paul Richard Thomas - Jan. 27, 2011, 8:45 p.m.
Dear All,

The attached patch started out, as they all do, as quite a simple,
unobtrusive looking thing.  However, like Topsy, it just grewed and
grewed.... :-)

It does a number of things:
(i) (Re)allocation on assignment of scalar, allocatable left hand sides;
(ii) Introduces allocatable, deferred character length scalars;
(iii) Allows said beasts to be passed and returned as dummies and
returned as function results;
(iv)  Introduces deferred character length scalar pointers;
(v) Allows them to be passed and returned as dummies but not as
functions results; and
(vi)  Implements MOLD = for allocation of deferred length character scalars.

We will have to go back to allocatable arrays to sort out the issues
there with deferred character length variables.  Deferred character
length derived type components also look as if they are now low
hanging fruit.

It bootstraps and regtests with tonight's trunk, except for:
FAIL: gfortran.dg/gomp/appendix-a/a.23.2.f90  -O  (internal compiler error)
FAIL: gfortran.dg/gomp/appendix-a/a.23.2.f90  -O  (test for excess errors)
FAIL: gfortran.dg/gomp/appendix-a/a.27.1.f90  -O  (internal compiler error)
FAIL: gfortran.dg/gomp/appendix-a/a.27.1.f90  -O  (test for excess errors)

Presuming that this has nothing to do with this patch - OK for trunk?

Paul and Tobias

2011-01-27  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-27  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.
Tobias Burnus - Jan. 27, 2011, 10:10 p.m.
Paul Richard Thomas wrote:
> It bootstraps and regtests with tonight's trunk, except for:
> FAIL: gfortran.dg/gomp/appendix-a/a.23.2.f90  -O  (internal compiler error)
> FAIL: gfortran.dg/gomp/appendix-a/a.23.2.f90  -O  (test for excess errors)
> FAIL: gfortran.dg/gomp/appendix-a/a.27.1.f90  -O  (internal compiler error)
> FAIL: gfortran.dg/gomp/appendix-a/a.27.1.f90  -O  (test for excess errors)

That should be fixed by now - however, you might need to bootstrap or at 
least "touch omp-low.c" to see the fix as the bug was not in omp-low.c 
but the file was "just" miscompiled. Cf. PR 47464.

To the patch:

*************** gfc_conv_procedure_call (gfc_se * se, gf
+       /* Deferred length dummys pass the character length by reference


s/dummys/dummies/

Otherwise, the patch looks OK.

I think the patch can be committed as everything is guarded by 
if(ts.deferred) and thus is save. Additionally, it prevents wrong 
code/user confusion: More and more users* expect that reallocate on 
assignment is implemented and given that gfortran supports it for 
arrays, the chance that they use it also for scalars is even higher, 
leading to (seemingly) random segfaults in the user programs. By the 
very nature of (re)allocate on assignment, those cases are not compile 
time diagnosable - thus, without the patch, one cannot even error out 
with "sorry not implemented".

Tobias

(* As seen e.g. on comp.lang.fortran, though I saw also reports elsewhere.)
Paul Richard Thomas - Jan. 28, 2011, 1:55 p.m.
Sending        gcc/fortran/ChangeLog
Sending        gcc/fortran/gfortran.texi
Sending        gcc/fortran/interface.c
Sending        gcc/fortran/match.c
Sending        gcc/fortran/module.c
Sending        gcc/fortran/resolve.c
Sending        gcc/fortran/trans-decl.c
Sending        gcc/fortran/trans-expr.c
Sending        gcc/fortran/trans-stmt.c
Sending        gcc/fortran/trans-types.c
Sending        gcc/testsuite/ChangeLog
Adding         gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03
Sending        gcc/testsuite/gfortran.dg/deferred_type_param_2.f90
Adding         gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03
Adding         gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03
Transmitting file data ...............
Committed revision 169356.

Thanks for the reviews Tobias and Jerry.

Cheers

Paul

Patch

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 169296)
--- gcc/fortran/interface.c	(working copy)
*************** compare_actual_formal (gfc_actual_arglis
*** 2093,2098 ****
--- 2093,2110 ----
  	   return 0;
  	 }
  
+       if ((f->sym->attr.pointer || f->sym->attr.allocatable)
+ 	    && f->sym->ts.deferred != a->expr->ts.deferred
+ 	    && a->expr->ts.type == BT_CHARACTER)
+ 	{
+ 	  if (where)
+ 	    gfc_error ("Actual argument argument at %L to allocatable or "
+ 		       "pointer dummy argument '%s' must have a deferred "
+ 		       "length type parameter if and only if the dummy has one",
+ 		       &a->expr->where, f->sym->name);
+ 	  return 0;
+ 	}
+ 
        actual_size = get_expr_storage_size (a->expr);
        formal_size = get_sym_storage_size (f->sym);
        if (actual_size != 0
*************** compare_actual_formal (gfc_actual_arglis
*** 2101,2114 ****
  	{
  	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
  	    gfc_warning ("Character length of actual argument shorter "
! 			"than of dummy argument '%s' (%lu/%lu) at %L",
! 			f->sym->name, actual_size, formal_size,
! 			&a->expr->where);
            else if (where)
  	    gfc_warning ("Actual argument contains too few "
! 			"elements for dummy argument '%s' (%lu/%lu) at %L",
! 			f->sym->name, actual_size, formal_size,
! 			&a->expr->where);
  	  return  0;
  	}
  
--- 2113,2126 ----
  	{
  	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
  	    gfc_warning ("Character length of actual argument shorter "
! 			 "than of dummy argument '%s' (%lu/%lu) at %L",
! 			 f->sym->name, actual_size, formal_size,
! 			 &a->expr->where);
            else if (where)
  	    gfc_warning ("Actual argument contains too few "
! 			 "elements for dummy argument '%s' (%lu/%lu) at %L",
! 			 f->sym->name, actual_size, formal_size,
! 			 &a->expr->where);
  	  return  0;
  	}
  
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 169296)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3322,3327 ****
--- 3322,3336 ----
          }
        end_pointer_check:
  
+       /* Deferred length dummys 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.  */
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3349,3355 ****
  	     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)
  	    cl.backend_decl = VEC_index (tree, stringargs, 0);
  	  else
  	    {
--- 3358,3366 ----
  	     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 (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
  	    {
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3534,3539 ****
--- 3545,3559 ----
  	  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);
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3642,3648 ****
  	      else
  	        se->expr = var;
  
! 	      se->string_length = len;
  	    }
  	  else
  	    {
--- 3662,3671 ----
  	      else
  	        se->expr = var;
  
! 	      if (!ts.deferred)
! 		se->string_length = len;
! 	      else if (sym->attr.allocatable || sym->attr.pointer)
! 		se->string_length = cl.backend_decl;
  	    }
  	  else
  	    {
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 4919,4926 ****
        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.  */
        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))
  	{
--- 4942,4952 ----
        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.  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))
  	{
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 4931,4936 ****
--- 4957,4973 ----
  				       &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));
  
*************** gfc_conv_string_parameter (gfc_se * se)
*** 5206,5213 ****
      }
  
    gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
-   gcc_assert (se->string_length
- 	  && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
  }
  
  
--- 5243,5248 ----
*************** expr_is_variable (gfc_expr *expr)
*** 5792,5797 ****
--- 5827,5962 ----
  }
  
  
+ /* 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
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5929,5934 ****
--- 6094,6108 ----
        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,
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5937,5942 ****
--- 6111,6122 ----
  
    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);
      }
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5972,5978 ****
  	  gfc_add_expr_to_block (&body, tmp);
  	}
  
!       /* Allocate or reallocate lhs of allocatable array.  */
        if (gfc_option.flag_realloc_lhs
  	    && gfc_is_reallocatable_lhs (expr1)
  	    && !gfc_expr_attr (expr1).codimension
--- 6152,6158 ----
  	  gfc_add_expr_to_block (&body, tmp);
  	}
  
!       /* F2003: Allocate or reallocate lhs of allocatable array.  */
        if (gfc_option.flag_realloc_lhs
  	    && gfc_is_reallocatable_lhs (expr1)
  	    && !gfc_expr_attr (expr1).codimension
*************** gfc_trans_assignment (gfc_expr * expr1, 
*** 6042,6054 ****
  {
    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)
      {
--- 6222,6227 ----
Index: gcc/fortran/gfortran.texi
===================================================================
*** gcc/fortran/gfortran.texi	(revision 169296)
--- gcc/fortran/gfortran.texi	(working copy)
*************** type-specification with type parameter a
*** 830,839 ****
  from a @code{SOURCE=} expression; @code{ALLOCATE} and @code{DEALLOCATE}
  optionally return an error message string via @code{ERRMSG=}.
  
! @item Reallocation on assignment for arrays: If an intrinsic assignment is
  used, an allocatable variable on the left-hand side is automatically allocated
! (if unallocated) or reallocated (if the shape is different). Currently, the
! reallocation for scalars is not implemented.
  
  @item Transferring of allocations via @code{MOVE_ALLOC}.
  
--- 830,840 ----
  from a @code{SOURCE=} expression; @code{ALLOCATE} and @code{DEALLOCATE}
  optionally return an error message string via @code{ERRMSG=}.
  
! @item Reallocation on assignment: If an intrinsic assignment is
  used, an allocatable variable on the left-hand side is automatically allocated
! (if unallocated) or reallocated (if the shape is different). Currently, scalar
! deferred character length left-hand sides are correctly handled but arrays
! are not yet fully implemented.
  
  @item Transferring of allocations via @code{MOVE_ALLOC}.
  
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 169296)
--- gcc/fortran/trans-stmt.c	(working copy)
***************
*** 1,5 ****
  /* Statement translation -- generate GCC trees from gfc_code.
!    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
     Free Software Foundation, Inc.
     Contributed by Paul Brook <paul@nowt.org>
     and Steven Bosscher <s.bosscher@student.tudelft.nl>
--- 1,6 ----
  /* Statement translation -- generate GCC trees from gfc_code.
!    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>
*************** gfc_trans_allocate (gfc_code * code)
*** 4507,4520 ****
  	      else
  		memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
  	    }
  	  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;
! 
  	  /* Allocate - for non-pointers with re-alloc checking.  */
  	  {
  	    gfc_ref *ref;
--- 4508,4580 ----
  	      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)
! 	    {
! 	      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;
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 169296)
--- gcc/fortran/module.c	(working copy)
*************** mio_typespec (gfc_typespec *ts)
*** 2138,2143 ****
--- 2138,2157 ----
    else
      mio_charlen (&ts->u.cl);
  
+   /* So as not to disturb the existing API, use an ATOM_NAME to
+      transmit deferred characteristic for characters (F2003).  */
+   if (iomode == IO_OUTPUT)
+     {
+       if (ts->type == BT_CHARACTER && ts->deferred)
+ 	write_atom (ATOM_NAME, "DEFERRED_CL");
+     }
+   else if (peek_atom () != ATOM_RPAREN)
+     {
+       if (parse_atom () != ATOM_NAME)
+ 	bad_module ("Expected string");
+       ts->deferred = 1;
+     }
+ 
    mio_rparen ();
  }
  
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c	(revision 169296)
--- gcc/fortran/trans-types.c	(working copy)
***************
*** 1,6 ****
  /* Backend support for Fortran 95 basic types and derived types.
     Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
!    2010
     Free Software Foundation, Inc.
     Contributed by Paul Brook <paul@nowt.org>
     and Steven Bosscher <s.bosscher@student.tudelft.nl>
--- 1,6 ----
  /* Backend support for Fortran 95 basic types and derived types.
     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>
*************** gfc_get_function_type (gfc_symbol * sym)
*** 2352,2358 ****
    tree typelist;
    gfc_formal_arglist *f;
    gfc_symbol *arg;
-   int nstr;
    int alternate_return;
  
    /* Make sure this symbol is a function, a subroutine or the main
--- 2352,2357 ----
*************** gfc_get_function_type (gfc_symbol * sym)
*** 2363,2369 ****
    if (sym->backend_decl)
      return TREE_TYPE (sym->backend_decl);
  
-   nstr = 0;
    alternate_return = 0;
    typelist = NULL_TREE;
  
--- 2362,2367 ----
*************** gfc_get_function_type (gfc_symbol * sym)
*** 2392,2398 ****
  
        typelist = gfc_chainon_list (typelist, type);
        if (arg->ts.type == BT_CHARACTER)
! 	typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
      }
  
    /* Build the argument types for the function.  */
--- 2390,2405 ----
  
        typelist = gfc_chainon_list (typelist, type);
        if (arg->ts.type == BT_CHARACTER)
! 	{
! 	  if (!arg->ts.deferred)
! 	    /* Transfer by value.  */
! 	    typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
! 	  else
! 	    /* Deferred character lengths are transferred by reference
! 	       so that the value can be returned.  */
! 	    typelist = gfc_chainon_list (typelist,
! 				build_pointer_type (gfc_charlen_type_node));
! 	}
      }
  
    /* Build the argument types for the function.  */
*************** gfc_get_function_type (gfc_symbol * sym)
*** 2428,2435 ****
  	     Contained procedures could pass by value as these are never
  	     used without an explicit interface, and cannot be passed as
  	     actual parameters for a dummy procedure.  */
! 	  if (arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
!             nstr++;
  	  typelist = gfc_chainon_list (typelist, type);
  	}
        else
--- 2435,2441 ----
  	     Contained procedures could pass by value as these are never
  	     used without an explicit interface, and cannot be passed as
  	     actual parameters for a dummy procedure.  */
! 
  	  typelist = gfc_chainon_list (typelist, type);
  	}
        else
*************** gfc_get_function_type (gfc_symbol * sym)
*** 2440,2447 ****
      }
  
    /* Add hidden string length parameters.  */
!   while (nstr--)
!     typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
  
    if (typelist)
      typelist = chainon (typelist, void_list_node);
--- 2446,2467 ----
      }
  
    /* Add hidden string length parameters.  */
!   for (f = sym->formal; f; f = f->next)
!     {
!       arg = f->sym;
!       if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
! 	{
! 	  if (!arg->ts.deferred)
! 	    /* Transfer by value.  */
! 	    type = gfc_charlen_type_node;
! 	  else
! 	    /* Deferred character lengths are transferred by reference
! 	       so that the value can be returned.  */
! 	    type = build_pointer_type (gfc_charlen_type_node);
! 
! 	  typelist = gfc_chainon_list (typelist, type);
! 	}
!     }
  
    if (typelist)
      typelist = chainon (typelist, void_list_node);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 169296)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_contained_fntype (gfc_symbol *sy
*** 500,506 ****
    if (sym->result->ts.type == BT_CHARACTER)
      {
        gfc_charlen *cl = sym->result->ts.u.cl;
!       if (!cl || !cl->length)
  	{
  	  /* See if this is a module-procedure and adapt error message
  	     accordingly.  */
--- 500,506 ----
    if (sym->result->ts.type == BT_CHARACTER)
      {
        gfc_charlen *cl = sym->result->ts.u.cl;
!       if ((!cl || !cl->length) && !sym->result->ts.deferred)
  	{
  	  /* See if this is a module-procedure and adapt error message
  	     accordingly.  */
*************** resolve_function (gfc_expr *expr)
*** 2990,2995 ****
--- 2990,2996 ----
        && sym->ts.u.cl
        && sym->ts.u.cl->length == NULL
        && !sym->attr.dummy
+       && !sym->ts.deferred
        && expr->value.function.esym == NULL
        && !sym->attr.contained)
      {
*************** check_symbols:
*** 6916,6927 ****
      }
  
  success:
-   if (e->ts.deferred)
-     {
-       gfc_error ("Support for entity at %L with deferred type parameter "
- 		 "not yet implemented", &e->where);
-       return FAILURE;
-     }
    return SUCCESS;
  
  failure:
--- 6917,6922 ----
*************** resolve_fl_procedure (gfc_symbol *sym, i
*** 10267,10274 ****
  	}
  
        /* Appendix B.2 of the standard.  Contained functions give an
! 	 error anyway.  Fixed-form is likely to be F77/legacy.  */
!       if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
  	gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
  			"CHARACTER(*) function '%s' at %L",
  			sym->name, &sym->declared_at);
--- 10262,10272 ----
  	}
  
        /* Appendix B.2 of the standard.  Contained functions give an
! 	 error anyway.  Fixed-form is likely to be F77/legacy. Deferred
! 	 character length is an F2003 feature.  */
!       if (!sym->attr.contained
! 	    && gfc_current_form != FORM_FIXED
! 	    && !sym->ts.deferred)
  	gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
  			"CHARACTER(*) function '%s' at %L",
  			sym->name, &sym->declared_at);
*************** resolve_fl_derived (gfc_symbol *sym)
*** 11605,11611 ****
  	  return FAILURE;
  	}
  
!       if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
  	{
  	 if (c->ts.u.cl->length == NULL
  	     || (resolve_charlen (c->ts.u.cl) == FAILURE)
--- 11603,11610 ----
  	  return FAILURE;
  	}
  
!       if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
! 	    && !c->ts.deferred)
  	{
  	 if (c->ts.u.cl->length == NULL
  	     || (resolve_charlen (c->ts.u.cl) == FAILURE)
*************** resolve_fl_derived (gfc_symbol *sym)
*** 11619,11624 ****
--- 11618,11632 ----
  	   }
  	}
  
+       if (c->ts.type == BT_CHARACTER && c->ts.deferred
+ 	  && !c->attr.pointer && !c->attr.allocatable)
+ 	{
+ 	  gfc_error ("Character component '%s' of '%s' at %L with deferred "
+ 		     "length must be a POINTER or ALLOCATABLE",
+ 		     c->name, sym->name, &c->loc);
+ 	  return FAILURE;
+ 	}
+ 
        if (c->ts.type == BT_DERIVED
  	  && sym->component_access != ACCESS_PRIVATE
  	  && gfc_check_access (sym->attr.access, sym->ns->default_access)
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 169296)
--- gcc/fortran/match.c	(working copy)
*************** alloc_opt_list:
*** 3134,3143 ****
      }
  
    /* Check F03:C623,  */
!   if (saw_deferred && ts.type == BT_UNKNOWN && !source)
      {
        gfc_error ("Allocate-object at %L with a deferred type parameter "
! 		 "requires either a type-spec or SOURCE tag", &deferred_locus);
        goto cleanup;
      }
    
--- 3134,3144 ----
      }
  
    /* Check F03:C623,  */
!   if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
      {
        gfc_error ("Allocate-object at %L with a deferred type parameter "
! 		 "requires either a type-spec or SOURCE tag or a MOLD tag",
! 		 &deferred_locus);
        goto cleanup;
      }
    
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 169296)
--- gcc/fortran/trans-decl.c	(working copy)
***************
*** 1,5 ****
  /* Backend function setup
!    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
     Free Software Foundation, Inc.
     Contributed by Paul Brook
  
--- 1,6 ----
  /* Backend function setup
!    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
!    2011
     Free Software Foundation, Inc.
     Contributed by Paul Brook
  
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1067,1072 ****
--- 1068,1088 ----
  	gfc_find_derived_vtab (c->ts.u.derived);
      }
  
+   /* All deferred character length procedures need to retain the backend
+      decl, which is a pointer to the character length in the caller's
+      namespace and to declare a local character length.  */
+   if (!byref && sym->attr.function
+ 	&& sym->ts.type == BT_CHARACTER
+ 	&& sym->ts.deferred
+ 	&& sym->ts.u.cl->passed_length == NULL
+ 	&& sym->ts.u.cl->backend_decl
+ 	&& TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
+     {
+       sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+       sym->ts.u.cl->backend_decl = NULL_TREE;
+       length = gfc_create_string_length (sym);
+     }
+ 
    if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
      {
        /* Return via extra parameter.  */
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1087,1092 ****
--- 1103,1122 ----
        /* Create a character length variable.  */
        if (sym->ts.type == BT_CHARACTER)
  	{
+ 	  /* For a deferred dummy, make a new string length variable.  */
+ 	  if (sym->ts.deferred
+ 		&&
+ 	     (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
+ 	    sym->ts.u.cl->backend_decl = NULL_TREE;
+ 
+ 	  if (sym->ts.deferred && sym->attr.result
+ 		&& sym->ts.u.cl->passed_length == NULL
+ 		&& sym->ts.u.cl->backend_decl)
+ 	    {
+ 	      sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+ 	      sym->ts.u.cl->backend_decl = NULL_TREE;
+ 	    }
+ 
  	  if (sym->ts.u.cl->backend_decl == NULL_TREE)
  	    length = gfc_create_string_length (sym);
  	  else
*************** create_function_arglist (gfc_symbol * sy
*** 1793,1799 ****
  	{
  	  /* Length of character result.  */
  	  tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
- 	  gcc_assert (len_type == gfc_charlen_type_node);
  
  	  length = build_decl (input_location,
  			       PARM_DECL,
--- 1823,1828 ----
*************** create_function_arglist (gfc_symbol * sy
*** 1879,1885 ****
  	{
  	  tree len_type = TREE_VALUE (hidden_typelist);
  	  tree length = NULL_TREE;
! 	  gcc_assert (len_type == gfc_charlen_type_node);
  
  	  strcpy (&name[1], f->sym->name);
  	  name[0] = '_';
--- 1908,1917 ----
  	{
  	  tree len_type = TREE_VALUE (hidden_typelist);
  	  tree length = NULL_TREE;
! 	  if (!f->sym->ts.deferred)
! 	    gcc_assert (len_type == gfc_charlen_type_node);
! 	  else
! 	    gcc_assert (POINTER_TYPE_P (len_type));
  
  	  strcpy (&name[1], f->sym->name);
  	  name[0] = '_';
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3182,3187 ****
--- 3214,3223 ----
    gfc_formal_arglist *f;
    stmtblock_t tmpblock;
    bool seen_trans_deferred_array = false;
+   tree tmp = NULL;
+   gfc_expr *e;
+   gfc_se se;
+   stmtblock_t init;
  
    /* Deal with implicit return variables.  Explicit return variables will
       already have been added.  */
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3213,3219 ****
  	}
        else if (proc_sym->ts.type == BT_CHARACTER)
  	{
! 	  if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
  	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
  	}
        else
--- 3249,3282 ----
  	}
        else if (proc_sym->ts.type == BT_CHARACTER)
  	{
! 	  if (proc_sym->ts.deferred)
! 	    {
! 	      tmp = NULL;
! 	      gfc_start_block (&init);
! 	      /* Zero the string length on entry.  */
! 	      gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
! 			      build_int_cst (gfc_charlen_type_node, 0));
! 	      /* Null the pointer.  */
! 	      e = gfc_lval_expr_from_sym (proc_sym);
! 	      gfc_init_se (&se, NULL);
! 	      se.want_pointer = 1;
! 	      gfc_conv_expr (&se, e);
! 	      gfc_free_expr (e);
! 	      tmp = se.expr;
! 	      gfc_add_modify (&init, tmp,
! 			      fold_convert (TREE_TYPE (se.expr),
! 					    null_pointer_node));
! 
! 	      /* Pass back the string length on exit.  */
! 	      tmp = proc_sym->ts.u.cl->passed_length;
! 	      tmp = build_fold_indirect_ref_loc (input_location, tmp);
! 	      tmp = fold_convert (gfc_charlen_type_node, tmp);
! 	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! 				     gfc_charlen_type_node, tmp,
! 				     proc_sym->ts.u.cl->backend_decl);
! 	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
! 	    }
! 	  else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
  	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
  	}
        else
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3304,3310 ****
  	  if (sym_has_alloc_comp && !seen_trans_deferred_array)
  	    gfc_trans_deferred_array (sym, block);
  	}
!       else if (!sym->attr.dummy
  		&& (sym->attr.allocatable
  		    || (sym->ts.type == BT_CLASS
  			&& CLASS_DATA (sym)->attr.allocatable)))
--- 3367,3373 ----
  	  if (sym_has_alloc_comp && !seen_trans_deferred_array)
  	    gfc_trans_deferred_array (sym, block);
  	}
!       else if ((!sym->attr.dummy || sym->ts.deferred)
  		&& (sym->attr.allocatable
  		    || (sym->ts.type == BT_CLASS
  			&& CLASS_DATA (sym)->attr.allocatable)))
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3313,3323 ****
  	    {
  	      /* Nullify and automatic deallocation of allocatable
  		 scalars.  */
- 	      tree tmp = NULL;
- 	      gfc_expr *e;
- 	      gfc_se se;
- 	      stmtblock_t init;
- 
  	      e = gfc_lval_expr_from_sym (sym);
  	      if (sym->ts.type == BT_CLASS)
  		gfc_add_data_component (e);
--- 3376,3381 ----
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3327,3341 ****
  	      gfc_conv_expr (&se, e);
  	      gfc_free_expr (e);
  
- 	      /* Nullify when entering the scope.  */
  	      gfc_start_block (&init);
! 	      gfc_add_modify (&init, se.expr,
! 			      fold_convert (TREE_TYPE (se.expr),
! 					    null_pointer_node));
  
  	      /* Deallocate when leaving the scope. Nullifying is not
  		 needed.  */
! 	      if (!sym->attr.result)
  		tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
  							 NULL, sym->ts);
  
--- 3385,3428 ----
  	      gfc_conv_expr (&se, e);
  	      gfc_free_expr (e);
  
  	      gfc_start_block (&init);
! 
! 	      if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
! 		{
! 		  /* Nullify when entering the scope.  */
! 		  gfc_add_modify (&init, se.expr,
! 				  fold_convert (TREE_TYPE (se.expr),
! 					        null_pointer_node));
! 		}
! 
! 	      if ((sym->attr.dummy ||sym->attr.result)
! 		    && sym->ts.type == BT_CHARACTER
! 		    && sym->ts.deferred)
! 		{
! 		  /* Character length passed by reference.  */
! 		  tmp = sym->ts.u.cl->passed_length;
! 		  tmp = build_fold_indirect_ref_loc (input_location, tmp);
! 		  tmp = fold_convert (gfc_charlen_type_node, tmp);
! 
! 		  if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
! 		    /* Zero the string length when entering the scope.  */
! 		    gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
! 				build_int_cst (gfc_charlen_type_node, 0));
! 		  else
! 		    gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
! 
! 		  /* Pass the final character length back.  */
! 		  if (sym->attr.intent != INTENT_IN)
! 		    tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! 					   gfc_charlen_type_node, tmp,
! 					   sym->ts.u.cl->backend_decl);
! 		  else
! 		    tmp = NULL_TREE;
! 		}
  
  	      /* Deallocate when leaving the scope. Nullifying is not
  		 needed.  */
! 	      if (!sym->attr.result && !sym->attr.dummy)
  		tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
  							 NULL, sym->ts);
  
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3358,3363 ****
--- 3445,3477 ----
  	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
  	    }
  	}
+       else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
+ 	{
+ 	  tree tmp = NULL;
+ 	  stmtblock_t init;
+ 
+ 	  /* If we get to here, all that should be left are pointers.  */
+ 	  gcc_assert (sym->attr.pointer);
+ 
+ 	  if (sym->attr.dummy)
+ 	    {
+ 	      gfc_start_block (&init);
+ 
+ 	      /* Character length passed by reference.  */
+ 	      tmp = sym->ts.u.cl->passed_length;
+ 	      tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ 	      tmp = fold_convert (gfc_charlen_type_node, tmp);
+ 	      gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
+ 	      /* Pass the final character length back.  */
+ 	      if (sym->attr.intent != INTENT_IN)
+ 		tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ 				       gfc_charlen_type_node, tmp,
+ 				       sym->ts.u.cl->backend_decl);
+ 	      else
+ 		tmp = NULL_TREE;
+ 	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+ 	    }
+ 	}
        else if (sym->ts.deferred)
  	gfc_fatal_error ("Deferred type parameter not yet supported");
        else if (sym_has_alloc_comp)
Index: gcc/testsuite/gfortran.dg/deferred_type_param_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_type_param_2.f90	(revision 169296)
--- gcc/testsuite/gfortran.dg/deferred_type_param_2.f90	(working copy)
*************** subroutine three()
*** 34,42 ****
    str1 = ["abc"]
    pstr2 => str1
  
!   allocate (character(len=77) :: str1(1)) ! OK ! { dg-error "not yet implemented" }
!   allocate (pstr, source=str2)  ! OK  ! { dg-error "not yet implemented" }
!   allocate (pstr, mold=str2) ! { dg-error "requires either a type-spec or SOURCE tag" }
    allocate (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" }
    allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" }
  
--- 34,42 ----
    str1 = ["abc"]
    pstr2 => str1
  
!   allocate (character(len=77) :: str1(1))
!   allocate (pstr, source=str2)
!   allocate (pstr, mold=str2)
    allocate (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" }
    allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" }
  
Index: gcc/testsuite/gfortran.dg/allocatable_function_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocatable_function_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/allocatable_function_5.f90	(revision 0)
***************
*** 0 ****
--- 1,48 ----
+ ! { dg-do run }
+ ! Tests function return of deferred length scalars.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+ module m
+ contains
+   function mfoo (carg) result(res)
+     character (:), allocatable :: res
+     character (*) :: carg
+     res = carg(2:4)
+   end function
+   function mbar (carg)
+     character (:), allocatable :: mbar
+     character (*) :: carg
+     mbar = carg(2:13)
+   end function
+ end module
+ 
+   use m
+   character (:), allocatable :: lhs
+   lhs = foo ("foo calling ")
+   if (lhs .ne. "foo") call abort
+   if (len (lhs) .ne. 3) call abort
+   deallocate (lhs)
+   lhs = bar ("bar calling - baaaa!")
+   if (lhs .ne. "bar calling") call abort
+   if (len (lhs) .ne. 12) call abort
+   deallocate (lhs)
+   lhs = mfoo ("mfoo calling ")
+   if (lhs .ne. "foo") call abort
+   if (len (lhs) .ne. 3) call abort
+   deallocate (lhs)
+   lhs = mbar ("mbar calling - baaaa!")
+   if (lhs .ne. "bar calling") call abort
+   if (len (lhs) .ne. 12) call abort
+ contains
+   function foo (carg) result(res)
+     character (:), allocatable :: res
+     character (*) :: carg
+     res = carg(1:3)
+   end function
+   function bar (carg)
+     character (:), allocatable :: bar
+     character (*) :: carg
+     bar = carg(1:12)
+   end function
+ end
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03	(revision 0)
***************
*** 0 ****
--- 1,87 ----
+ ! { dg-do run }
+ ! Test (re)allocation on assignment of scalars
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+   call test_real
+   call test_derived
+   call test_char1
+   call test_char4
+   call test_deferred_char1
+   call test_deferred_char4
+ contains
+   subroutine test_real
+     real, allocatable :: x
+     real :: y = 42
+     x = 42.0
+     if (x .ne. y) call abort
+     deallocate (x)
+     x = y
+     if (x .ne. y) call abort
+   end subroutine   
+   subroutine test_derived
+     type :: mytype
+       real :: x
+       character(4) :: c
+     end type
+     type (mytype), allocatable :: t
+     t = mytype (99.0, "abcd")
+     if (t%c .ne. "abcd") call abort
+   end subroutine   
+   subroutine test_char1
+     character(len = 8), allocatable :: c1
+     character(len = 8) :: c2 = "abcd1234"
+     c1 = "abcd1234"
+     if (c1 .ne. c2) call abort
+     deallocate (c1)
+     c1 = c2
+     if (c1 .ne. c2) call abort
+   end subroutine    
+   subroutine test_char4
+     character(len = 8, kind = 4), allocatable :: c1
+     character(len = 8, kind = 4) :: c2 = 4_"abcd1234"
+     c1 = 4_"abcd1234"
+     if (c1 .ne. c2) call abort
+     deallocate (c1)
+     c1 = c2
+     if (c1 .ne. c2) call abort
+   end subroutine
+   subroutine test_deferred_char1  
+     character(:), allocatable :: c
+     c = "Hello"
+     if (c .ne. "Hello") call abort
+     if (len(c) .ne. 5) call abort
+     c = "Goodbye"
+     if (c .ne. "Goodbye") call abort
+     if (len(c) .ne. 7) call abort
+ ! Check that the hidden LEN dummy is passed by reference
+     call test_pass_c1 (c)
+     if (c .ne. "Made in test!") print *, c
+     if (len(c) .ne. 13) call abort
+   end subroutine
+   subroutine test_pass_c1 (carg)
+     character(:), allocatable :: carg
+     if (carg .ne. "Goodbye") call abort
+     if (len(carg) .ne. 7) call abort
+     carg = "Made in test!"
+   end subroutine
+   subroutine test_deferred_char4
+     character(:, kind = 4), allocatable :: c
+     c = 4_"Hello"
+     if (c .ne. 4_"Hello") call abort
+     if (len(c) .ne. 5) call abort
+     c = 4_"Goodbye"
+     if (c .ne. 4_"Goodbye") call abort
+     if (len(c) .ne. 7) call abort
+ ! Check that the hidden LEN dummy is passed by reference
+     call test_pass_c4 (c)
+     if (c .ne. 4_"Made in test!") print *, c
+     if (len(c) .ne. 13) call abort
+   end subroutine
+   subroutine test_pass_c4 (carg)
+     character(:, kind = 4), allocatable :: carg
+     if (carg .ne. 4_"Goodbye") call abort
+     if (len(carg) .ne. 7) call abort
+     carg = 4_"Made in test!"
+   end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_5.f90	(revision 0)
***************
*** 0 ****
--- 1,267 ----
+ ! { dg-do run}
+ !
+ ! Automatic reallocate on assignment, deferred length parameter for char
+ !
+ ! PR fortran/45170
+ ! PR fortran/35810
+ ! PR fortran/47350
+ !
+ ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+ program test
+   implicit none
+   call mold_check()
+   call mold_check4()
+   call source_check()
+   call source_check4()
+   call ftn_test()
+   call ftn_test4()
+   call source3()
+ contains
+   subroutine source_check()
+     character(len=:), allocatable :: str, str2
+     target :: str
+     character(len=8) :: str3
+     character(len=:), pointer :: str4, str5
+     nullify(str4)
+     str3 = 'AbCdEfGhIj'
+     if(allocated(str)) call abort()
+     allocate(str, source=str3)
+     if(.not.allocated(str)) call abort()
+     if(len(str) /= 8) call abort()
+     if(str /= 'AbCdEfGh') call abort()
+     if(associated(str4)) call abort()
+     str4 => str
+     if(str4 /= str .or. len(str4)/=8) call abort()
+     if(.not.associated(str4, str)) call abort()
+     str4 => null()
+     str = '12a56b78'
+     if(str4 == '12a56b78') call abort()
+     str4 = 'ABCDEFGH'
+     if(str == 'ABCDEFGH') call abort()
+     allocate(str5, source=str)
+     if(associated(str5, str)) call abort()
+     if(str5 /= '12a56b78' .or. len(str5)/=8) call abort()
+     str = 'abcdef'
+     if(str5 == 'abcdef') call abort()
+     str5 = 'ABCDEF'
+     if(str == 'ABCDEF') call abort()
+   end subroutine source_check
+   subroutine source_check4()
+     character(kind=4,len=:), allocatable :: str, str2
+     target :: str
+     character(kind=4,len=8) :: str3
+     character(kind=4,len=:), pointer :: str4, str5
+     nullify(str4)
+     str3 = 4_'AbCdEfGhIj'
+     if(allocated(str)) call abort()
+     allocate(str, source=str3)
+     if(.not.allocated(str)) call abort()
+     if(len(str) /= 8) call abort()
+     if(str /= 4_'AbCdEfGh') call abort()
+     if(associated(str4)) call abort()
+     str4 => str
+     if(str4 /= str .or. len(str4)/=8) call abort()
+     if(.not.associated(str4, str)) call abort()
+     str4 => null()
+     str = 4_'12a56b78'
+     if(str4 == 4_'12a56b78') call abort()
+     str4 = 4_'ABCDEFGH'
+     if(str == 4_'ABCDEFGH') call abort()
+     allocate(str5, source=str)
+     if(associated(str5, str)) call abort()
+     if(str5 /= 4_'12a56b78' .or. len(str5)/=8) call abort()
+     str = 4_'abcdef'
+     if(str5 == 4_'abcdef') call abort()
+     str5 = 4_'ABCDEF'
+     if(str == 4_'ABCDEF') call abort()
+   end subroutine source_check4
+   subroutine mold_check()
+     character(len=:), allocatable :: str, str2
+     character(len=8) :: str3
+     character(len=:), pointer :: str4, str5
+     nullify(str4)
+     str2 = "ABCE"
+     ALLOCATE( str, MOLD=str3)
+     if (len(str) /= 8) call abort()
+     DEALLOCATE(str)
+     ALLOCATE( str, MOLD=str2)
+     if (len(str) /= 4) call abort()
+ 
+     IF (associated(str4)) call abort()
+     ALLOCATE( str4, MOLD=str3)
+     IF (.not.associated(str4)) call abort()
+     str4 = '12345678'
+     if (len(str4) /= 8) call abort()
+     if(str4 /= '12345678') call abort()
+     DEALLOCATE(str4)
+     ALLOCATE( str4, MOLD=str2)
+     str4 = 'ABCD'
+     if (len(str4) /= 4) call abort()
+     if (str4 /= 'ABCD') call abort()
+     str5 => str4
+     if(.not.associated(str4,str5)) call abort()
+     if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort()
+     if(str5 /= str4) call abort()
+     deallocate(str4) 
+   end subroutine mold_check
+   subroutine mold_check4()
+     character(len=:,kind=4), allocatable :: str, str2
+     character(len=8,kind=4) :: str3
+     character(len=:,kind=4), pointer :: str4, str5
+     nullify(str4)
+     str2 = 4_"ABCE"
+     ALLOCATE( str, MOLD=str3)
+     if (len(str) /= 8) call abort()
+     DEALLOCATE(str)
+     ALLOCATE( str, MOLD=str2)
+     if (len(str) /= 4) call abort()
+ 
+     IF (associated(str4)) call abort()
+     ALLOCATE( str4, MOLD=str3)
+     IF (.not.associated(str4)) call abort()
+     str4 = 4_'12345678'
+     if (len(str4) /= 8) call abort()
+     if(str4 /= 4_'12345678') call abort()
+     DEALLOCATE(str4)
+     ALLOCATE( str4, MOLD=str2)
+     str4 = 4_'ABCD'
+     if (len(str4) /= 4) call abort()
+     if (str4 /= 4_'ABCD') call abort()
+     str5 => str4
+     if(.not.associated(str4,str5)) call abort()
+     if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort()
+     if(str5 /= str4) call abort()
+     deallocate(str4) 
+   end subroutine mold_check4
+   subroutine ftn_test()
+     character(len=:), allocatable :: str_a
+     character(len=:), pointer     :: str_p
+     nullify(str_p) 
+     call proc_test(str_a, str_p, .false.)
+     if (str_p /= '123457890abcdef') call abort()
+     if (len(str_p) /= 50) call abort()
+     if (str_a(1:5) /= 'ABCDE ') call abort()
+     if (len(str_a) /= 50) call abort()
+     deallocate(str_p)
+     str_a = '1245'
+     if(len(str_a) /= 4) call abort()
+     if(str_a /= '1245') call abort()
+     allocate(character(len=6) :: str_p)
+     if(len(str_p) /= 6) call abort()
+     str_p = 'AbCdEf'
+     call proc_test(str_a, str_p, .true.)
+     if (str_p /= '123457890abcdef') call abort()
+     if (len(str_p) /= 50) call abort()
+     if (str_a(1:5) /= 'ABCDE ') call abort()
+     if (len(str_a) /= 50) call abort()
+     deallocate(str_p)
+   end subroutine ftn_test
+   subroutine proc_test(a, p, alloc)
+     character(len=:), allocatable :: a
+     character(len=:), pointer     :: p
+     character(len=5), target :: loc
+     logical :: alloc
+     if (.not.  alloc) then
+       if(associated(p)) call abort()
+       if(allocated(a)) call abort()
+     else
+       if(len(a) /= 4) call abort()
+       if(a /= '1245') call abort()
+       if(len(p) /= 6) call abort()
+       if(p /= 'AbCdEf') call abort()
+       deallocate(a)
+       nullify(p)
+     end if
+     allocate(character(len=50) :: a)
+     a(1:5) = 'ABCDE'
+     if(len(a) /= 50) call abort()
+     if(a(1:5) /= "ABCDE") call abort()
+     loc = '12345'
+     p => loc
+     if (len(p) /= 5) call abort()
+     if (p /= '12345') call abort()
+     p = '12345679'
+     if (len(p) /= 5) call abort()
+     if (p /= '12345') call abort()
+     p = 'ABC'
+     if (loc /= 'ABC  ') call abort()
+     allocate(p, mold=a)
+     if (.not.associated(p)) call abort()
+     p = '123457890abcdef'
+     if (p /= '123457890abcdef') call abort()
+     if (len(p) /= 50) call abort()
+   end subroutine proc_test
+   subroutine ftn_test4()
+     character(len=:,kind=4), allocatable :: str_a
+     character(len=:,kind=4), pointer     :: str_p
+     nullify(str_p) 
+     call proc_test4(str_a, str_p, .false.)
+     if (str_p /= 4_'123457890abcdef') call abort()
+     if (len(str_p) /= 50) call abort()
+     if (str_a(1:5) /= 4_'ABCDE ') call abort()
+     if (len(str_a) /= 50) call abort()
+     deallocate(str_p)
+     str_a = 4_'1245'
+     if(len(str_a) /= 4) call abort()
+     if(str_a /= 4_'1245') call abort()
+     allocate(character(len=6, kind = 4) :: str_p)
+     if(len(str_p) /= 6) call abort()
+     str_p = 4_'AbCdEf'
+     call proc_test4(str_a, str_p, .true.)
+     if (str_p /= 4_'123457890abcdef') call abort()
+     if (len(str_p) /= 50) call abort()
+     if (str_a(1:5) /= 4_'ABCDE ') call abort()
+     if (len(str_a) /= 50) call abort()
+     deallocate(str_p)
+   end subroutine ftn_test4
+   subroutine proc_test4(a, p, alloc)
+     character(len=:,kind=4), allocatable :: a
+     character(len=:,kind=4), pointer     :: p
+     character(len=5,kind=4), target :: loc
+     logical :: alloc
+     if (.not.  alloc) then
+       if(associated(p)) call abort()
+       if(allocated(a)) call abort()
+     else
+       if(len(a) /= 4) call abort()
+       if(a /= 4_'1245') call abort()
+       if(len(p) /= 6) call abort()
+       if(p /= 4_'AbCdEf') call abort()
+       deallocate(a)
+       nullify(p)
+     end if
+     allocate(character(len=50,kind=4) :: a)
+     a(1:5) = 4_'ABCDE'
+     if(len(a) /= 50) call abort()
+     if(a(1:5) /= 4_"ABCDE") call abort()
+     loc = '12345'
+     p => loc
+     if (len(p) /= 5) call abort()
+     if (p /= 4_'12345') call abort()
+     p = 4_'12345679'
+     if (len(p) /= 5) call abort()
+     if (p /= 4_'12345') call abort()
+     p = 4_'ABC'
+     if (loc /= 4_'ABC  ') call abort()
+     allocate(p, mold=a)
+     if (.not.associated(p)) call abort()
+     p = 4_'123457890abcdef'
+     if (p /= 4_'123457890abcdef') call abort()
+     if (len(p) /= 50) call abort()
+   end subroutine proc_test4
+   subroutine source3()
+      character(len=:, kind=1), allocatable :: a1
+      character(len=:, kind=4), allocatable :: a4
+      character(len=:, kind=1), pointer     :: p1
+      character(len=:, kind=4), pointer     :: p4
+      allocate(a1, source='ABC') ! << ICE
+      if(len(a1) /= 3 .or. a1 /= 'ABC') call abort()
+      allocate(a4, source=4_'12345') ! << ICE
+      if(len(a4) /= 5 .or. a4 /= 4_'12345') call abort()
+      allocate(p1, mold='AB') ! << ICE
+      if(len(p1) /= 2) call abort()
+      allocate(p4, mold=4_'145') ! << ICE
+      if(len(p4) /= 3) call abort()
+   end subroutine source3
+ end program test
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03	(revision 0)
***************
*** 0 ****
--- 1,49 ----
+ ! { dg-do run }
+ ! Tests function return of deferred length scalars.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+ module m
+ contains
+   function mfoo (carg) result(res)
+     character (:), allocatable :: res
+     character (*) :: carg
+     res = carg(2:4)
+   end function
+   function mbar (carg)
+     character (:), allocatable :: mbar
+     character (*) :: carg
+     mbar = carg(2:13)
+   end function
+ end module
+ 
+   use m
+   character (:), allocatable :: lhs
+   lhs = foo ("foo calling ")
+   if (lhs .ne. "foo") call abort
+   if (len (lhs) .ne. 3) call abort
+   deallocate (lhs)
+   lhs = bar ("bar calling - baaaa!")
+   if (lhs .ne. "bar calling") call abort
+   if (len (lhs) .ne. 12) call abort
+   deallocate (lhs)
+   lhs = mfoo ("mfoo calling ")
+   if (lhs .ne. "foo") call abort
+   if (len (lhs) .ne. 3) call abort
+   deallocate (lhs)
+   lhs = mbar ("mbar calling - baaaa!")
+   if (lhs .ne. "bar calling") call abort
+   if (len (lhs) .ne. 12) call abort
+ contains
+   function foo (carg) result(res)
+     character (:), allocatable :: res
+     character (*) :: carg
+     res = carg(1:3)
+   end function
+   function bar (carg)
+     character (:), allocatable :: bar
+     character (*) :: carg
+     bar = carg(1:12)
+   end function
+ end
+