Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 3152 bytes --]

Dear All,

I am completely unable to reproduce the problems that Dominique is
reporting for deferred_character_4.f90. This might be because the
patch has moved on to fix PR49554 :-)

Concatenation expressions assigned to deferred length character arrays
need careful handling to ensure that the temporary creation for the
concatenation operator occurs at the right place, that the descriptor
dtype is updated and an array temporary is created if there is any
dependency between lhs and rhs. This latter has been implemented in
resolve.c.

Testcases 4-6 have been added to reflect the additional fixes afforded
by the original patch, as reported by Dominique (thanks!).

As soon as this patch has been committed, I will prepare a version for
4.9 and 5 branches

Bootstrapped and regtested on FC21/x86_64 - OK for trunk?

Paul

2015-15-08  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/50221
    PR fortran/68216
    PR fortran/63932
    PR fortran/66408
    * trans_array.c (gfc_conv_scalarized_array_ref): Pass the
    symbol decl for deferred character length array references.
    * trans-stmt.c (gfc_trans_allocate): Keep the string lengths
    to update deferred length character string lengths.
    * trans-types.c (gfc_get_dtype_rank_type); Use the string
    length of deferred character types for the dtype size.
    * trans.c (gfc_build_array_ref): For references to deferred
    character arrays, use the domain max value, if it is a variable
    to set the 'span' and use pointer arithmetic for acces to the
    element.
    (trans_code): Set gfc_current_locus for diagnostic purposes.

    PR fortran/67674
    * trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
    string lengths of components.

    PR fortran/49954
    * resolve.c (deferred_op_assign): New function.
    (gfc_resolve_code): Call it.
    * trans-array.c (concat_str_length): New function.
    (gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
    realloc blocks for deferred character length arrays because the
    string length might change, even if the shape is the same. Call
    concat_str_length to obtain the string length for concatenation
    since it is needed to compute the lhs string length.
    Set the descriptor dtype appropriately for the new string
    length.
    * trans-expr.c (gfc_trans_assignment_1): Use the rse string
    length for all characters, other than deferred types. For
    concatenation operators, push the rse.pre block to the inner
    most loop so that the temporary pointer and the assignments
    are properly placed.

2015-15-08  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/50221
    * gfortran.dg/deferred_character_1.f90: New test.
    * gfortran.dg/deferred_character_4.f90: New test for comment
    #4 of the PR.

    PR fortran/68216
    * gfortran.dg/deferred_character_2.f90: New test.

    PR fortran/67674
    * gfortran.dg/deferred_character_3.f90: New test.

    PR fortran/63932
    * gfortran.dg/deferred_character_5.f90: New test.

    PR fortran/66408
    * gfortran.dg/deferred_character_6.f90: New test.

    PR fortran/49954
    * gfortran.dg/deferred_character_7.f90: New test.

[-- Attachment #2: resubmit.diff --]
[-- Type: text/plain, Size: 27591 bytes --]

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 229953)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_ptr_fcn_assign (gfc_code **code,
*** 10222,10227 ****
--- 10222,10271 ----
  }
  
  
+ /* Deferred character length assignments from an operator expression
+    require a temporary because the character length of the lhs can
+    change in the course of the assignment.  */
+ 
+ static bool
+ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
+ {
+   gfc_expr *tmp_expr;
+   gfc_code *this_code;
+ 
+   if (!((*code)->expr1->ts.type == BT_CHARACTER
+ 	 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
+ 	 && (*code)->expr2->expr_type == EXPR_OP))
+     return false;
+ 
+   if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
+     return false;
+ 
+   tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+   tmp_expr->where = (*code)->loc;
+ 
+   /* A new charlen is required to ensure that the variable string
+      length is different to that of the original lhs.  */
+   tmp_expr->ts.u.cl = gfc_get_charlen();
+   tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
+   tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
+   (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
+ 
+   tmp_expr->symtree->n.sym->ts.deferred = 1;
+ 
+   this_code = build_assignment (EXEC_ASSIGN,
+ 				(*code)->expr1,
+ 				gfc_copy_expr (tmp_expr),
+ 				NULL, NULL, (*code)->loc);
+ 
+   (*code)->expr1 = tmp_expr;
+ 
+   this_code->next = (*code)->next;
+   (*code)->next = this_code;
+ 
+   return true;
+ }
+ 
+ 
  /* Given a block of code, recursively resolve everything pointed to by this
     code block.  */
  
*************** start:
*** 10427,10432 ****
--- 10471,10481 ----
  		goto call;
  	    }
  
+ 	  /* Check for dependencies in deferred character length array
+ 	     assignments and generate a temporary, if necessary.  */
+ 	  if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
+ 	    break;
+ 
  	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
  	  if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
  	      && code->expr1->ts.u.derived
*************** gfc_verify_binding_labels (gfc_symbol *s
*** 10801,10807 ****
        sym->binding_label = NULL;
  
      }
!   else if (sym->attr.flavor == FL_VARIABLE && module 
  	   && (strcmp (module, gsym->mod_name) != 0
  	       || strcmp (sym->name, gsym->sym_name) != 0))
      {
--- 10850,10856 ----
        sym->binding_label = NULL;
  
      }
!   else if (sym->attr.flavor == FL_VARIABLE && module
  	   && (strcmp (module, gsym->mod_name) != 0
  	       || strcmp (sym->name, gsym->sym_name) != 0))
      {
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 229953)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3168,3174 ****
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && is_subref_array (expr))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
--- 3168,3175 ----
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && (is_subref_array (expr)
! 	       || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE)))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
*************** gfc_is_reallocatable_lhs (gfc_expr *expr
*** 8501,8506 ****
--- 8502,8576 ----
  }
  
  
+ static tree
+ concat_str_length (gfc_expr* expr)
+ {
+   tree type;
+   tree len1;
+   tree len2;
+   gfc_se se;
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
+   len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len1 == NULL_TREE)
+     {
+       if (expr->value.op.op1->expr_type == EXPR_OP)
+ 	len1 = concat_str_length (expr->value.op.op1);
+       else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
+ 	len1 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op1->value.character.length);
+       else if (expr->value.op.op1->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
+ 	  len1 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op1);
+ 	  len1 = se.string_length;
+ 	}
+     }
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
+   len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len2 == NULL_TREE)
+     {
+       if (expr->value.op.op2->expr_type == EXPR_OP)
+ 	len2 = concat_str_length (expr->value.op.op2);
+       else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
+ 	len2 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op2->value.character.length);
+       else if (expr->value.op.op2->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
+ 	  len2 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op2);
+ 	  len2 = se.string_length;
+ 	}
+     }
+ 
+   gcc_assert(len1 && len2);
+   len1 = fold_convert (gfc_charlen_type_node, len1);
+   len2 = fold_convert (gfc_charlen_type_node, len2);
+ 
+   return fold_build2_loc (input_location, PLUS_EXPR,
+ 			  gfc_charlen_type_node, len1, len2);
+ }
+ 
+ 
  /* Allocate the lhs of an assignment to an allocatable array, otherwise
     reallocate it.  */
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8598,8603 ****
--- 8668,8679 ----
    /* Allocate if data is NULL.  */
    cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));
+ 
+   if (expr1->ts.deferred)
+     cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
+   else
+     cond_null= gfc_evaluate_now (cond_null, &fblock);
+ 
    tmp = build3_v (COND_EXPR, cond_null,
  		  build1_v (GOTO_EXPR, jump_label1),
  		  build_empty_stmt (input_location));
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8686,8692 ****
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
  			  size1, size2);
!   neq_size = gfc_evaluate_now (cond, &fblock);
  
    /* Deallocation of allocatable components will have to occur on
       reallocation.  Fix the old descriptor now.  */
--- 8762,8774 ----
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
  			  size1, size2);
! 
!   /* If the lhs is deferred length, assume that the element size
!      changes and force a reallocation.  */
!   if (expr1->ts.deferred)
!     neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
!   else
!     neq_size = gfc_evaluate_now (cond, &fblock);
  
    /* Deallocation of allocatable components will have to occur on
       reallocation.  Fix the old descriptor now.  */
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8791,8796 ****
--- 8873,8884 ----
        else
  	{
  	  tmp = expr2->ts.u.cl->backend_decl;
+ 	  if (!tmp && expr2->expr_type == EXPR_OP
+ 	      && expr2->value.op.op == INTRINSIC_CONCAT)
+ 	    {
+ 	      tmp = concat_str_length (expr2);
+ 	      expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ 	    }
  	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
  	}
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8818,8823 ****
--- 8906,8927 ----
  			   size2, size_one_node);
    size2 = gfc_evaluate_now (size2, &fblock);
  
+   /* For deferred character length, the 'size' field of the dtype might
+      have changed so set the dtype.  */
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+       && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+     {
+       tree type;
+       tmp = gfc_conv_descriptor_dtype (desc);
+       if (expr2->ts.u.cl->backend_decl)
+ 	type = gfc_typenode_for_spec (&expr2->ts);
+       else
+ 	type = gfc_typenode_for_spec (&expr1->ts);
+ 
+       gfc_add_modify (&fblock, tmp,
+ 		      gfc_get_dtype_rank_type (expr1->rank,type));
+     }
+ 
    /* Realloc expression.  Note that the scalarizer uses desc.data
       in the array reference - (*desc.data)[<element>].  */
    gfc_init_block (&realloc_block);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8860,8867 ****
  			     1, size2);
    gfc_conv_descriptor_data_set (&alloc_block,
  				desc, tmp);
!   tmp = gfc_conv_descriptor_dtype (desc);
!   gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
    if ((expr1->ts.type == BT_DERIVED)
  	&& expr1->ts.u.derived->attr.alloc_comp)
      {
--- 8964,8979 ----
  			     1, size2);
    gfc_conv_descriptor_data_set (&alloc_block,
  				desc, tmp);
! 
!   /* We already set the dtype in the case of deferred character
!      length arrays.  */
!   if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
!         && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
!     {
!       tmp = gfc_conv_descriptor_dtype (desc);
!       gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
!     }
! 
    if ((expr1->ts.type == BT_DERIVED)
  	&& expr1->ts.u.derived->attr.alloc_comp)
      {
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 229953)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5601,5607 ****
  	  else
  	    {
  	      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);
  	    }
--- 5601,5608 ----
  	  else
  	    {
  	      tmp = parmse.string_length;
! 	      if (TREE_CODE (tmp) != VAR_DECL
! 		  && TREE_CODE (tmp) != COMPONENT_REF)
  		tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
  	      parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
  	    }
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 9252,9259 ****
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
    else
      string_length = NULL_TREE;
  
--- 9253,9262 ----
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+   else if (expr2->ts.type == BT_CHARACTER)
+     string_length = rse.string_length;
    else
      string_length = NULL_TREE;
  
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 9287,9294 ****
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.  */
!   if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
--- 9290,9303 ----
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.
!      NOTE ALSO: The concatenation operation generates a temporary pointer,
!      whose allocation must go to the innermost loop.  */
!   if (flag_realloc_lhs
!       && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
!       && !(lss != gfc_ss_terminator
! 	   && expr2->expr_type == EXPR_OP
! 	   && expr2->value.op.op == INTRINSIC_CONCAT))
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 229953)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5089,5094 ****
--- 5089,5095 ----
    tree label_finish;
    tree memsz;
    tree al_vptr, al_len;
+   tree def_str_len = NULL_TREE;
    /* If an expr3 is present, then store the tree for accessing its
       _vptr, and _len components in the variables, respectively.  The
       element size, i.e. _vptr%size, is stored in expr3_esize.  Any of
*************** gfc_trans_allocate (gfc_code * code)
*** 5466,5471 ****
--- 5467,5473 ----
  	  expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
  					 TREE_TYPE (se_sz.expr),
  					 tmp, se_sz.expr);
+ 	  def_str_len = gfc_evaluate_now (se_sz.expr, &block);
  	}
      }
  
*************** gfc_trans_allocate (gfc_code * code)
*** 5517,5522 ****
--- 5519,5535 ----
  
        se.want_pointer = 1;
        se.descriptor_only = 1;
+ 
+       if (expr->ts.type == BT_CHARACTER
+ 	  && expr->ts.deferred
+ 	  && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL
+ 	  && def_str_len != NULL_TREE)
+ 	{
+ 	  tmp = expr->ts.u.cl->backend_decl;
+ 	  gfc_add_modify (&block, tmp,
+ 			  fold_convert (TREE_TYPE (tmp), def_str_len));
+ 	}
+ 
        gfc_conv_expr (&se, expr);
        if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
  	/* se.string_length now stores the .string_length variable of expr
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 229953)
--- gcc/fortran/trans.c	(working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 334,339 ****
--- 334,351 ----
  
    type = TREE_TYPE (type);
  
+   /* Use pointer arithmetic for deferred character length array
+      references.  */
+   if (type && TREE_CODE (type) == ARRAY_TYPE
+       && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
+       && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL
+       && decl
+       && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ 					== DECL_CONTEXT (decl))
+     span = TYPE_MAXVAL (TYPE_DOMAIN (type));
+   else
+     span = NULL_TREE;
+ 
    if (DECL_P (base))
      TREE_ADDRESSABLE (base) = 1;
  
*************** gfc_build_array_ref (tree base, tree off
*** 348,355 ****
  		|| TREE_CODE (decl) == PARM_DECL)
         && ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	    && !integer_zerop (GFC_DECL_SPAN (decl)))
! 	   || GFC_DECL_CLASS (decl)))
!       || vptr)
      {
        if (decl)
  	{
--- 360,368 ----
  		|| TREE_CODE (decl) == PARM_DECL)
         && ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	    && !integer_zerop (GFC_DECL_SPAN (decl)))
! 	   || GFC_DECL_CLASS (decl)
! 	   || span != NULL_TREE))
!       || vptr != NULL_TREE)
      {
        if (decl)
  	{
*************** gfc_build_array_ref (tree base, tree off
*** 379,384 ****
--- 392,399 ----
  	    }
  	  else if (GFC_DECL_SUBREF_ARRAY_P (decl))
  	    span = GFC_DECL_SPAN (decl);
+ 	  else if (span)
+ 	    span = fold_convert (gfc_array_index_type, span);
  	  else
  	    gcc_unreachable ();
  	}
*************** trans_code (gfc_code * code, tree cond)
*** 1623,1628 ****
--- 1638,1644 ----
  	  gfc_add_expr_to_block (&block, res);
  	}
  
+       gfc_current_locus = code->loc;
        gfc_set_backend_locus (&code->loc);
  
        switch (code->op)
Index: gcc/testsuite/gfortran.dg/deferred_character_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_1.f90	(working copy)
***************
*** 0 ****
--- 1,40 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR50221
+ !
+ ! Contributed by Clive Page  <clivegpage@gmail.com>
+ !            and Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+ ! This is from comment #2 by Tobias Burnus.
+ !
+ module m
+   character(len=:), save, allocatable :: str(:)
+   character(len=2), parameter :: const(3) = ["a1", "b2", "c3"]
+ end
+ 
+   use m
+   call test()
+   if(allocated(str)) deallocate(str)
+   call foo
+ contains
+   subroutine test()
+     call doit()
+ !    print *, 'strlen=',len(str),' / array size =',size(str)
+ !    print '(3a)', '>',str(1),'<'
+ !    print '(3a)', '>',str(2),'<'
+ !    print '(3a)', '>',str(3),'<'
+     if (any (str .ne. const)) call abort
+   end subroutine test
+   subroutine doit()
+     str = const
+   end subroutine doit
+   subroutine foo
+ !
+ ! This is the original PR from Clive Page
+ !
+     character(:), allocatable, dimension(:) :: array
+     array = (/'xx', 'yy', 'zz'/)
+ !    print *, 'array=', array, len(array(1)), size(array)
+     if (any (array .ne. ["xx", "yy", "zz"])) call abort
+   end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/deferred_character_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_2.f90	(working copy)
***************
*** 0 ****
--- 1,85 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR68216
+ !
+ ! Reported on clf: https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc
+ !
+ PROGRAM hello
+ !
+ ! This is based on the first testcase, from Francisco (Ayyy LMAO). Original
+ ! lines are commented out. The second testcase from this thread is acalled
+ ! at the end of the program.
+ !
+     IMPLICIT NONE
+ 
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
+     character (3), dimension (2) :: array_fijo = ["abc","def"]
+     character (100) :: buffer
+     INTEGER :: largo , cant_lineas , i
+ 
+     write (buffer, "(2a3)") array_fijo
+ 
+ !    WRITE(*,*) ' Escriba un numero para el largo de cada linea'
+ !    READ(*,*) largo
+     largo = LEN (array_fijo)
+ 
+ !    WRITE(*,*) ' Escriba la cantidad de lineas'
+ !    READ(*,*) cant_lineas
+     cant_lineas = size (array_fijo, 1)
+ 
+     ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))
+ 
+ !    WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas)
+     READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)
+ 
+ !    WRITE(*,*) 'Array guardado: '
+ !    DO i=1,cant_lineas
+ !    WRITE(*,*) array_lineas(i)
+ !    ENDDO
+      if (any (array_lineas .ne. array_fijo)) call abort
+ 
+ ! The following are additional tests beyond that of the original.
+ !
+ ! Check that allocation with source = another deferred length is OK
+      allocate (array_copia, source = array_lineas)
+      if (any (array_copia .ne. array_fijo)) call abort
+      deallocate (array_lineas, array_copia)
+ 
+ ! Check that allocation with source = a non-deferred length is OK
+      allocate (array_lineas, source = array_fijo)
+      if (any (array_lineas .ne. array_fijo)) call abort
+      deallocate (array_lineas)
+ 
+ ! Check that allocation with MOLD = a non-deferred length is OK
+      allocate (array_copia, mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)])
+      if (size (array_copia, 1) .ne. 4) call abort
+      if (LEN (array_copia, 1) .ne. 2) call abort
+ 
+ ! Check that allocation with MOLD = another deferred length is OK
+      allocate (array_lineas, mold = array_copia)
+      if (size (array_copia, 1) .ne. 4) call abort
+      if (LEN (array_copia, 1) .ne. 2) call abort
+      deallocate (array_lineas, array_copia)
+ 
+ !    READ(*,*)
+      call testdefchar
+ contains
+      subroutine testdefchar
+ !
+ ! This is the testcase in the above thread from Blokbuster
+ !
+           implicit none
+           character(:), allocatable :: test(:)
+ 
+           allocate(character(3) :: test(2))
+           test(1) = 'abc'
+           test(2) = 'def'
+           if (any (test .ne. ['abc', 'def'])) call abort
+ 
+           test = ['aa','bb','cc']
+           if (any (test .ne. ['aa', 'bb', 'cc'])) call abort
+ 
+      end subroutine testdefchar
+ 
+ END PROGRAM
Index: gcc/testsuite/gfortran.dg/deferred_character_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_3.f90	(working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! {dg_do run }
+ !
+ ! Tests the fix for PR67674
+ !
+ ! Contributed by Kristopher Kuhlman  <kristopher.kuhlman@gmail.com>
+ !
+ program test
+   implicit none
+ 
+   type string_type
+     character(len=:), allocatable :: name
+   end type string_type
+   type(string_type), allocatable :: my_string_type
+ 
+   allocate(my_string_type)
+   allocate(character(len=0) :: my_string_type%name)
+ 
+ !  print *, 'length main program before',len(my_string_type%name)
+ 
+   call inputreadword1(my_string_type%name)
+ 
+ !  print *, 'length main program after',len(my_string_type%name)
+ !  print *, 'final result:',my_string_type%name
+   if (my_string_type%name .ne. 'here the word is finally set') call abort
+ 
+ contains
+   subroutine inputreadword1(word_intermediate)
+     character(len=:), allocatable :: word_intermediate
+ 
+ !    print *, 'length intermediate before',len(word_intermediate)
+     call inputreadword2(word_intermediate)
+ !    print *, 'length intermediate after',len(word_intermediate)
+ !    print *, word_intermediate
+ 
+   end subroutine inputreadword1
+ 
+   subroutine inputreadword2(word)
+     character(len=:), allocatable :: word
+ 
+ !    print *, 'length inner before',len(word)
+     word = 'here the word is finally set' ! want automatic reallocation to happen here
+ !    print *, 'length inner after',len(word)
+ !    print *, word
+ 
+   end subroutine inputreadword2
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_4.f90	(working copy)
***************
*** 0 ****
--- 1,30 ----
+ ! { dg-do run }
+ !
+ ! Check that PR50221 comment #4 is fixed.
+ !
+ ! Contributed by Arjen Makus  <arjen.markus895@gmail.com>
+ !
+ program chk_alloc_string
+     implicit none
+ 
+     character(len=:), dimension(:), allocatable :: strings
+     character(20) :: buffer
+     integer :: i
+ 
+     allocate( character(10):: strings(1:3) )
+ 
+     strings = [ "A   ", "C   ", "ABCD", "V   " ]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 4) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V"])) call abort
+ 
+     strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 5) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) call abort
+ 
+     write (buffer, "(5a4)") strings
+     if (buffer .ne. "A   C   ABCDV   zzzz") call abort
+ end program chk_alloc_string
Index: gcc/testsuite/gfortran.dg/deferred_character_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_5.f90	(working copy)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR63932 stays fixed.
+ !
+ ! Contributed by Valery Weber  <valeryweber@hotmail.com>
+ !
+ module mod
+   type :: t
+      character(:), allocatable :: c
+      integer :: i
+    contains
+      procedure, pass :: get
+   end type t
+   type :: u
+      character(:), allocatable :: c
+   end type u
+ contains
+   subroutine get(this, a)
+     class(t), intent(in) :: this
+     character(:), allocatable, intent(out), optional :: a
+     if (present (a)) a = this%c
+   end subroutine get
+ end module mod
+ 
+ program test
+   use mod
+   type(t) :: a
+   type(u) :: b
+   a%c = 'something'
+   call a%get (a = b%c)
+   if (b%c .ne. 'something') call abort
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_6.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_6.f90	(working copy)
***************
*** 0 ****
--- 1,54 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR66408 stays fixed.
+ !
+ ! Contributed by <werner.blokbuster@gmail.com>
+ !
+ module mytest
+ 
+     implicit none
+ 
+     type vary
+         character(:), allocatable :: string
+     end type vary
+ 
+     interface assignment(=)
+         module procedure char_eq_vary
+     end interface assignment(=)
+ 
+ contains
+ 
+     subroutine char_eq_vary(my_char,my_vary)
+         character(:), allocatable, intent(out) :: my_char
+         type(vary), intent(in) :: my_vary
+         my_char = my_vary%string
+     end subroutine char_eq_vary
+ 
+ end module mytest
+ 
+ 
+ program thistest
+ 
+     use mytest, only: vary, assignment(=)
+     implicit none
+ 
+     character(:), allocatable :: test_char
+     character(14), parameter :: str = 'example string'
+     type(vary) :: test_vary
+     type(vary) :: my_stuff
+ 
+ 
+     test_vary%string = str
+     if (test_vary%string .ne. str) call abort
+ 
+ ! This previously gave a blank string.
+     my_stuff%string = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+     test_char = test_vary
+     if (test_char .ne. str) call abort
+ 
+     my_stuff = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+ end program thistest
Index: gcc/testsuite/gfortran.dg/deferred_character_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_7.f90	(working copy)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for pr49954, in which concatenation to deferred length character
+ ! arrays, at best, did not work correctly.
+ !
+ !
+ !
+ implicit none
+   character(len=:), allocatable :: a1(:)
+   character(len=:), allocatable :: a2(:), a3(:)
+   character(len=:), allocatable :: b1
+   character(len=:), allocatable :: b2
+   character(8) :: chr = "IJKLMNOP"
+   character(48) :: buffer
+ 
+   a1 = ["ABCDEFGH","abcdefgh"]
+   a2 = "_"//a1//chr//"_"
+   if (any (a2 .ne. ["_ABCDEFGHIJKLMNOP_","_abcdefghIJKLMNOP_"])) call abort
+ 
+ ! Check that the descriptor dtype is OK - the array write needs it.
+   write (buffer, "(2a18)") a2
+   if (trim (buffer) .ne. "_ABCDEFGHIJKLMNOP__abcdefghIJKLMNOP_") call abort
+ 
+ ! Make sure scalars survived the fix!
+   b1 = "ABCDEFGH"
+   b2 = "_"//b1//chr//"_"
+   if (b2 .ne. "_ABCDEFGHIJKLMNOP_") call abort
+ 
+ ! Check the dependency is detected and dealt with by generation of a temporary.
+   a1 = "?"//a1//"?"
+   if (any (a1 .ne. ["?ABCDEFGH?","?abcdefgh?"])) call abort
+ ! With an array reference...
+   a1 = "?"//a1(1:2)//"?"
+   if (any (a1 .ne. ["??ABCDEFGH??","??abcdefgh??"])) call abort
+ !... together with a substring.
+   a1 = "?"//a1(1:1)(2:4)//"?"
+   if (any (a1 .ne. ["??AB?"])) call abort
+ contains
+ end

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Steve Kargl]

On Sat, Nov 14, 2015 at 06:39:28PM +0100, Paul Richard Thomas wrote:
> 
> I am completely unable to reproduce the problems that Dominique is
> reporting for deferred_character_4.f90. This might be because the
> patch has moved on to fix PR49554 :-)
> 
> Concatenation expressions assigned to deferred length character arrays
> need careful handling to ensure that the temporary creation for the
> concatenation operator occurs at the right place, that the descriptor
> dtype is updated and an array temporary is created if there is any
> dependency between lhs and rhs. This latter has been implemented in
> resolve.c.
> 
> Testcases 4-6 have been added to reflect the additional fixes afforded
> by the original patch, as reported by Dominique (thanks!).
> 
> As soon as this patch has been committed, I will prepare a version for
> 4.9 and 5 branches
> 
> Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
> 

Hi Paul,

I was going to cast an eye over your diff today.  I'll
build and run some tests on FreeBSD.  Dominiq uses 
MacOS.  So, perhaps, some latent memory corruption 
issue. 

-- 
steve

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

Hi Steve,

Following an email from Dominique to me, I think not. In the course of
fixing PR49954, I put right the setting of the descriptor dtype. Since
this gets passed to the IO runtime, I think that this is the reason
for the difference in behaviour.

I think that another week of effort should put right gfortran's woes
with deferred characters. As well as concatenation problems that I
think I have fixed, parentheses cause instant death :-(

Cheers

Paul


On 14 November 2015 at 18:49, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Sat, Nov 14, 2015 at 06:39:28PM +0100, Paul Richard Thomas wrote:
>>
>> I am completely unable to reproduce the problems that Dominique is
>> reporting for deferred_character_4.f90. This might be because the
>> patch has moved on to fix PR49554 :-)
>>
>> Concatenation expressions assigned to deferred length character arrays
>> need careful handling to ensure that the temporary creation for the
>> concatenation operator occurs at the right place, that the descriptor
>> dtype is updated and an array temporary is created if there is any
>> dependency between lhs and rhs. This latter has been implemented in
>> resolve.c.
>>
>> Testcases 4-6 have been added to reflect the additional fixes afforded
>> by the original patch, as reported by Dominique (thanks!).
>>
>> As soon as this patch has been committed, I will prepare a version for
>> 4.9 and 5 branches
>>
>> Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
>>
>
> Hi Paul,
>
> I was going to cast an eye over your diff today.  I'll
> build and run some tests on FreeBSD.  Dominiq uses
> MacOS.  So, perhaps, some latent memory corruption
> issue.
>
> --
> steve



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Dominique d'Humières]

Dear Paul,

Update with your latest patch. Using the following patch

--- /opt/gcc/work/gcc/testsuite/gfortran.dg/deferred_character_4.f90	2015-11-14 19:28:59.000000000 +0100
+++ deferred_character_4_db.f90	2015-11-14 19:43:55.000000000 +0100
@@ -21,6 +21,16 @@ program chk_alloc_string
 
     strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
 
+    print *, len(strings), size(strings, 1)
+    do i = 1, size(strings, 1)
+      print *, "'",strings(i),"'"
+    end do
+    print *, "other print"
+    print *, (strings(i), i= 1, size(strings, 1))
+    print *, "'", strings(1),"' '", strings(2), "' '", strings(3), "' '", strings(4), "' '", strings(5), "'"
+    print *, "'", strings, "'"
+    print '(">",a,"<")', strings
+    print '(">",a,"<")', strings(1:5)
     if (len(strings) .ne. 4) call abort
     if (size(strings, 1) .ne. 5) call abort
     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) call abort

the output is now correct except the one for print '(">",a,"<")', strings(1:5) which is now

>A   <
>A   <
>A   <
>A   <
>A   <

It was correct with the previous patch.

Everything else looks good.

IMO the latest issue may be delayed after a commit!-)

Dominique

> Le 14 nov. 2015 à 19:25, Paul Richard Thomas <paul.richard.thomas@gmail.com> a écrit :
> 
> Hi Steve,
> 
> Following an email from Dominique to me, I think not. In the course of
> fixing PR49954, I put right the setting of the descriptor dtype. Since
> this gets passed to the IO runtime, I think that this is the reason
> for the difference in behaviour.
> 
> I think that another week of effort should put right gfortran's woes
> with deferred characters. As well as concatenation problems that I
> think I have fixed, parentheses cause instant death :-(
> 
> Cheers
> 
> Paul

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

Dear Dominique et al.,

This problem I can reproduce :-) I can even see what the problem is,
although I can do nothing about it for an hour or so because I have
updated trunk, ready for the commit, and am rebuilding/regtesting.

print '(">",a,"<")', strings(1:5) produces:

  {
    struct __st_parameter_dt dt_parm.0;

    dt_parm.0.common.filename = &"deferred_character_4.f90"[1]{lb: 1 sz: 1};
    dt_parm.0.common.line = 34;
    dt_parm.0.format = &"(\">\",a4,\"<\")"[1]{lb: 1 sz: 1};
    dt_parm.0.format_len = 12;
    dt_parm.0.common.flags = 4096;
    dt_parm.0.common.unit = 6;
    _gfortran_st_write (&dt_parm.0);
    {
      struct array1_unknown parm.1;

      parm.1.dtype = ((integer(kind=8)) SAVE_EXPR <(sizetype)
NON_LVALUE_EXPR <.strings>> << 6) + 49;
      parm.1.dim[0].lbound = 1;
      parm.1.dim[0].ubound = 5;
      parm.1.dim[0].stride = 1;
      parm.1.data = (void *) &(*(character(kind=1)[0:][1:.strings] *
restrict) strings.data)[1 - strings.dim[0].lbound];
      parm.1.offset = 0;
      _gfortran_transfer_array_write (&dt_parm.0, &parm.1, 1, .strings);
    }
    _gfortran_st_write_done (&dt_parm.0);
  }

This is fine, except for the data pointer offset for 'parm.1', where a
normal array reference is used. This happens in
trans-array.c(gfc_get_dataptr_offset). Line 6403,   tmp =
build_array_ref (desc, offset, NULL, NULL); which does not use the
opportunity to pass the backend_decl for 'strings', thereby triggering
the use of pointer arithmetic for the offset.

This has not changed between the versions of the patch, so it is
something of a miracle that it ever worked.

I will check this diagnosis before committing and will put it right,
accordingly. I will also update the testcase to include an array
section.

Cheers

Paul

On 14 November 2015 at 19:55, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> Dear Paul,
>
> Update with your latest patch. Using the following patch
>
> --- /opt/gcc/work/gcc/testsuite/gfortran.dg/deferred_character_4.f90    2015-11-14 19:28:59.000000000 +0100
> +++ deferred_character_4_db.f90 2015-11-14 19:43:55.000000000 +0100
> @@ -21,6 +21,16 @@ program chk_alloc_string
>
>      strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
>
> +    print *, len(strings), size(strings, 1)
> +    do i = 1, size(strings, 1)
> +      print *, "'",strings(i),"'"
> +    end do
> +    print *, "other print"
> +    print *, (strings(i), i= 1, size(strings, 1))
> +    print *, "'", strings(1),"' '", strings(2), "' '", strings(3), "' '", strings(4), "' '", strings(5), "'"
> +    print *, "'", strings, "'"
> +    print '(">",a,"<")', strings
> +    print '(">",a,"<")', strings(1:5)
>      if (len(strings) .ne. 4) call abort
>      if (size(strings, 1) .ne. 5) call abort
>      if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) call abort
>
> the output is now correct except the one for print '(">",a,"<")', strings(1:5) which is now
>
>>A   <
>>A   <
>>A   <
>>A   <
>>A   <
>
> It was correct with the previous patch.
>
> Everything else looks good.
>
> IMO the latest issue may be delayed after a commit!-)
>
> Dominique
>
>> Le 14 nov. 2015 à 19:25, Paul Richard Thomas <paul.richard.thomas@gmail.com> a écrit :
>>
>> Hi Steve,
>>
>> Following an email from Dominique to me, I think not. In the course of
>> fixing PR49954, I put right the setting of the descriptor dtype. Since
>> this gets passed to the IO runtime, I think that this is the reason
>> for the difference in behaviour.
>>
>> I think that another week of effort should put right gfortran's woes
>> with deferred characters. As well as concatenation problems that I
>> think I have fixed, parentheses cause instant death :-(
>>
>> Cheers
>>
>> Paul



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Steve Kargl]

On Sat, Nov 14, 2015 at 07:25:29PM +0100, Paul Richard Thomas wrote:
> 
> Following an email from Dominique to me, I think not. In the course of
> fixing PR49954, I put right the setting of the descriptor dtype. Since
> this gets passed to the IO runtime, I think that this is the reason
> for the difference in behaviour.
> 
> I think that another week of effort should put right gfortran's woes
> with deferred characters. As well as concatenation problems that I
> think I have fixed, parentheses cause instant death :-(
> 

Hi Paul,

I built and tested on both x86_64-*-freebsd and i386-*-freebsd.
All tests passed.

I read through the patch did not raise any red (or what
the heck is he doing here) flags.

OK to commit as this is a step in the right direction in
dealing with deferred character issues.

-- 
Steve

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

Dear Steve,

Thanks for the review.

Committed as revision 230396.

My diagnosis of the last problem that Dominique found is correct.
However, I have not succeeded in fixing it and so the patch was
committed as review. I'll just have to return to the problem this
evening.

Cheers

Paul

On 14 November 2015 at 21:10, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Sat, Nov 14, 2015 at 07:25:29PM +0100, Paul Richard Thomas wrote:
>>
>> Following an email from Dominique to me, I think not. In the course of
>> fixing PR49954, I put right the setting of the descriptor dtype. Since
>> this gets passed to the IO runtime, I think that this is the reason
>> for the difference in behaviour.
>>
>> I think that another week of effort should put right gfortran's woes
>> with deferred characters. As well as concatenation problems that I
>> think I have fixed, parentheses cause instant death :-(
>>
>
> Hi Paul,
>
> I built and tested on both x86_64-*-freebsd and i386-*-freebsd.
> All tests passed.
>
> I read through the patch did not raise any red (or what
> the heck is he doing here) flags.
>
> OK to commit as this is a step in the right direction in
> dealing with deferred character issues.
>
> --
> Steve



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 4726 bytes --]

Dear All,

In running through the PRs assigned to me, I realised that I have not
closed these PRs because I had promised to see if the patch would
apply to 4.9 and 5 branch.

I have just applied the patch to 5 branch and have found that, apart
from two minor tweaks in trans.c, all was well. It bootstrapped
 and regtested fine, apart from deferred_character_2.f90. In this
latter, deferred length SOURCE and MOLD do not work because the
requisite patches in gfc_trans_allocate were not backported.  In
addition, I had to add explicit array specifications to the allocate
statements.

Should I get deferred length SOURCE and MOLD to work or apply the
attached patch as it stands? Alternatively, I could forget about 4.9
and 5 branches and close the PRs.

I have added the ChangeLogs below.

Cheers

Paul

2015-12-18  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/50221
    PR fortran/68216
    PR fortran/63932
    PR fortran/66408
    * trans_array.c (gfc_conv_scalarized_array_ref): Pass the
    symbol decl for deferred character length array references.
    * trans-stmt.c (gfc_trans_allocate): Keep the string lengths
    to update deferred length character string lengths.
    * trans-types.c (gfc_get_dtype_rank_type); Use the string
    length of deferred character types for the dtype size.
    * trans.c (gfc_build_array_ref): For references to deferred
    character arrays, use the domain max value, if it is a variable
    to set the 'span' and use pointer arithmetic for acces to the
    element.
    (trans_code): Set gfc_current_locus for diagnostic purposes.

    PR fortran/67674
    * trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
    string lengths of components.

    PR fortran/49954
    * resolve.c (deferred_op_assign): New function.
    (gfc_resolve_code): Call it.
    * trans-array.c (concat_str_length): New function.
    (gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
    realloc blocks for deferred character length arrays because the
    string length might change, even if the shape is the same. Call
    concat_str_length to obtain the string length for concatenation
    since it is needed to compute the lhs string length.
    Set the descriptor dtype appropriately for the new string
    length.
    * trans-expr.c (gfc_trans_assignment_1): Use the rse string
    length for all characters, other than deferred types. For
    concatenation operators, push the rse.pre block to the inner
    most loop so that the temporary pointer and the assignments
    are properly placed.

2015-12-18  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/50221
    * gfortran.dg/deferred_character_1.f90: New test.
    * gfortran.dg/deferred_character_4.f90: New test for comment
    #4 of the PR.

    PR fortran/68216
    * gfortran.dg/deferred_character_2.f90: New test.

    PR fortran/67674
    * gfortran.dg/deferred_character_3.f90: New test.

    PR fortran/63932
    * gfortran.dg/deferred_character_5.f90: New test.

    PR fortran/66408
    * gfortran.dg/deferred_character_6.f90: New test.

    PR fortran/49954
    * gfortran.dg/deferred_character_7.f90: New test.

On 15 November 2015 at 15:13, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear Steve,
>
> Thanks for the review.
>
> Committed as revision 230396.
>
> My diagnosis of the last problem that Dominique found is correct.
> However, I have not succeeded in fixing it and so the patch was
> committed as review. I'll just have to return to the problem this
> evening.
>
> Cheers
>
> Paul
>
> On 14 November 2015 at 21:10, Steve Kargl
> <sgk@troutmask.apl.washington.edu> wrote:
>> On Sat, Nov 14, 2015 at 07:25:29PM +0100, Paul Richard Thomas wrote:
>>>
>>> Following an email from Dominique to me, I think not. In the course of
>>> fixing PR49954, I put right the setting of the descriptor dtype. Since
>>> this gets passed to the IO runtime, I think that this is the reason
>>> for the difference in behaviour.
>>>
>>> I think that another week of effort should put right gfortran's woes
>>> with deferred characters. As well as concatenation problems that I
>>> think I have fixed, parentheses cause instant death :-(
>>>
>>
>> Hi Paul,
>>
>> I built and tested on both x86_64-*-freebsd and i386-*-freebsd.
>> All tests passed.
>>
>> I read through the patch did not raise any red (or what
>> the heck is he doing here) flags.
>>
>> OK to commit as this is a step in the right direction in
>> dealing with deferred character issues.
>>
>> --
>> Steve
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

[-- Attachment #2: submit5.diff --]
[-- Type: text/plain, Size: 26777 bytes --]

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 230837)
--- gcc/fortran/resolve.c	(working copy)
*************** generate_component_assignments (gfc_code
*** 9992,9997 ****
--- 9992,10041 ----
  }
  
  
+ /* Deferred character length assignments from an operator expression
+    require a temporary because the character length of the lhs can
+    change in the course of the assignment.  */
+ 
+ static bool
+ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
+ {
+   gfc_expr *tmp_expr;
+   gfc_code *this_code;
+ 
+   if (!((*code)->expr1->ts.type == BT_CHARACTER
+ 	 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
+ 	 && (*code)->expr2->expr_type == EXPR_OP))
+     return false;
+ 
+   if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
+     return false;
+ 
+   tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+   tmp_expr->where = (*code)->loc;
+ 
+   /* A new charlen is required to ensure that the variable string
+      length is different to that of the original lhs.  */
+   tmp_expr->ts.u.cl = gfc_get_charlen();
+   tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
+   tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
+   (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
+ 
+   tmp_expr->symtree->n.sym->ts.deferred = 1;
+ 
+   this_code = build_assignment (EXEC_ASSIGN,
+ 				(*code)->expr1,
+ 				gfc_copy_expr (tmp_expr),
+ 				NULL, NULL, (*code)->loc);
+ 
+   (*code)->expr1 = tmp_expr;
+ 
+   this_code->next = (*code)->next;
+   (*code)->next = this_code;
+ 
+   return true;
+ }
+ 
+ 
  /* Given a block of code, recursively resolve everything pointed to by this
     code block.  */
  
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10189,10194 ****
--- 10233,10243 ----
  		goto call;
  	    }
  
+ 	  /* Check for dependencies in deferred character length array
+ 	     assignments and generate a temporary, if necessary.  */
+ 	  if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
+ 	    break;
+ 
  	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
  	  if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
  	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 230837)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3112,3118 ****
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && is_subref_array (expr))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
--- 3112,3119 ----
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && (is_subref_array (expr)
! 	       || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE)))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
*************** gfc_is_reallocatable_lhs (gfc_expr *expr
*** 8267,8272 ****
--- 8268,8342 ----
  }
  
  
+ static tree
+ concat_str_length (gfc_expr* expr)
+ {
+   tree type;
+   tree len1;
+   tree len2;
+   gfc_se se;
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
+   len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len1 == NULL_TREE)
+     {
+       if (expr->value.op.op1->expr_type == EXPR_OP)
+ 	len1 = concat_str_length (expr->value.op.op1);
+       else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
+ 	len1 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op1->value.character.length);
+       else if (expr->value.op.op1->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
+ 	  len1 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op1);
+ 	  len1 = se.string_length;
+ 	}
+     }
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
+   len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len2 == NULL_TREE)
+     {
+       if (expr->value.op.op2->expr_type == EXPR_OP)
+ 	len2 = concat_str_length (expr->value.op.op2);
+       else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
+ 	len2 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op2->value.character.length);
+       else if (expr->value.op.op2->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
+ 	  len2 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op2);
+ 	  len2 = se.string_length;
+ 	}
+     }
+ 
+   gcc_assert(len1 && len2);
+   len1 = fold_convert (gfc_charlen_type_node, len1);
+   len2 = fold_convert (gfc_charlen_type_node, len2);
+ 
+   return fold_build2_loc (input_location, PLUS_EXPR,
+ 			  gfc_charlen_type_node, len1, len2);
+ }
+ 
+ 
  /* Allocate the lhs of an assignment to an allocatable array, otherwise
     reallocate it.  */
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8364,8369 ****
--- 8434,8445 ----
    /* Allocate if data is NULL.  */
    cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));
+ 
+   if (expr1->ts.deferred)
+     cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
+   else
+     cond_null= gfc_evaluate_now (cond_null, &fblock);
+ 
    tmp = build3_v (COND_EXPR, cond_null,
  		  build1_v (GOTO_EXPR, jump_label1),
  		  build_empty_stmt (input_location));
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8452,8457 ****
--- 8528,8539 ----
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
  			  size1, size2);
+ 
+   /* If the lhs is deferred length, assume that the element size
+      changes and force a reallocation.  */
+   if (expr1->ts.deferred)
+     neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
+   else
      neq_size = gfc_evaluate_now (cond, &fblock);
  
    /* Deallocation of allocatable components will have to occur on
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8557,8562 ****
--- 8639,8650 ----
        else
  	{
  	  tmp = expr2->ts.u.cl->backend_decl;
+ 	  if (!tmp && expr2->expr_type == EXPR_OP
+ 	      && expr2->value.op.op == INTRINSIC_CONCAT)
+ 	    {
+ 	      tmp = concat_str_length (expr2);
+ 	      expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ 	    }
  	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
  	}
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8584,8589 ****
--- 8672,8693 ----
  			   size2, size_one_node);
    size2 = gfc_evaluate_now (size2, &fblock);
  
+   /* For deferred character length, the 'size' field of the dtype might
+      have changed so set the dtype.  */
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+       && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+     {
+       tree type;
+       tmp = gfc_conv_descriptor_dtype (desc);
+       if (expr2->ts.u.cl->backend_decl)
+ 	type = gfc_typenode_for_spec (&expr2->ts);
+       else
+ 	type = gfc_typenode_for_spec (&expr1->ts);
+ 
+       gfc_add_modify (&fblock, tmp,
+ 		      gfc_get_dtype_rank_type (expr1->rank,type));
+     }
+ 
    /* Realloc expression.  Note that the scalarizer uses desc.data
       in the array reference - (*desc.data)[<element>].  */
    gfc_init_block (&realloc_block);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8626,8633 ****
--- 8730,8745 ----
  			     1, size2);
    gfc_conv_descriptor_data_set (&alloc_block,
  				desc, tmp);
+ 
+   /* We already set the dtype in the case of deferred character
+      length arrays.  */
+   if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+         && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
+     {
        tmp = gfc_conv_descriptor_dtype (desc);
        gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+     }
+ 
    if ((expr1->ts.type == BT_DERIVED)
  	&& expr1->ts.u.derived->attr.alloc_comp)
      {
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 230837)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5343,5349 ****
  	  else
  	    {
  	      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);
  	    }
--- 5343,5350 ----
  	  else
  	    {
  	      tmp = parmse.string_length;
! 	      if (TREE_CODE (tmp) != VAR_DECL
! 		  && TREE_CODE (tmp) != COMPONENT_REF)
  		tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
  	      parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
  	    }
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 8998,9005 ****
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
    else
      string_length = NULL_TREE;
  
--- 8999,9008 ----
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+   else if (expr2->ts.type == BT_CHARACTER)
+     string_length = rse.string_length;
    else
      string_length = NULL_TREE;
  
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 9033,9040 ****
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.  */
!   if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
--- 9036,9049 ----
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.
!      NOTE ALSO: The concatenation operation generates a temporary pointer,
!      whose allocation must go to the innermost loop.  */
!   if (flag_realloc_lhs
!       && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
!       && !(lss != gfc_ss_terminator
! 	   && expr2->expr_type == EXPR_OP
! 	   && expr2->value.op.op == INTRINSIC_CONCAT))
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 230837)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5073,5078 ****
--- 5073,5079 ----
    tree label_finish;
    tree memsz;
    tree al_vptr, al_len;
+   tree def_str_len = NULL_TREE;
    /* If an expr3 is present, then store the tree for accessing its
       _vptr, and _len components in the variables, respectively.  The
       element size, i.e. _vptr%size, is stored in expr3_esize.  Any of
*************** gfc_trans_allocate (gfc_code * code)
*** 5335,5340 ****
--- 5336,5342 ----
  	  expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
  					 TREE_TYPE (se_sz.expr),
  					 tmp, se_sz.expr);
+ 	  def_str_len = gfc_evaluate_now (se_sz.expr, &block);
  	}
      }
  
*************** gfc_trans_allocate (gfc_code * code)
*** 5386,5391 ****
--- 5388,5404 ----
  
        se.want_pointer = 1;
        se.descriptor_only = 1;
+ 
+       if (expr->ts.type == BT_CHARACTER
+ 	  && expr->ts.deferred
+ 	  && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL
+ 	  && def_str_len != NULL_TREE)
+ 	{
+ 	  tmp = expr->ts.u.cl->backend_decl;
+ 	  gfc_add_modify (&block, tmp,
+ 			  fold_convert (TREE_TYPE (tmp), def_str_len));
+ 	}
+ 
        gfc_conv_expr (&se, expr);
        if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
  	/* se.string_length now stores the .string_length variable of expr
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 230837)
--- gcc/fortran/trans.c	(working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 344,349 ****
--- 344,361 ----
  
    type = TREE_TYPE (type);
  
+   /* Use pointer arithmetic for deferred character length array
+      references.  */
+   if (type && TREE_CODE (type) == ARRAY_TYPE
+       && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
+       && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL
+       && decl
+       && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ 					== DECL_CONTEXT (decl))
+     span = TYPE_MAXVAL (TYPE_DOMAIN (type));
+   else
+     span = NULL_TREE;
+ 
    if (DECL_P (base))
      TREE_ADDRESSABLE (base) = 1;
  
*************** gfc_build_array_ref (tree base, tree off
*** 358,364 ****
  		 || TREE_CODE (decl) == PARM_DECL)
  	&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	      && !integer_zerop (GFC_DECL_SPAN(decl)))
! 	   || GFC_DECL_CLASS (decl)))
      {
        if (GFC_DECL_CLASS (decl))
  	{
--- 370,377 ----
  		 || TREE_CODE (decl) == PARM_DECL)
  	&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	      && !integer_zerop (GFC_DECL_SPAN(decl)))
! 	   || GFC_DECL_CLASS (decl)
! 	   || span != NULL_TREE))
      {
        if (GFC_DECL_CLASS (decl))
  	{
*************** gfc_build_array_ref (tree base, tree off
*** 377,382 ****
--- 390,397 ----
  	}
        else if (GFC_DECL_SUBREF_ARRAY_P (decl))
  	span = GFC_DECL_SPAN(decl);
+       else if (span)
+ 	span = fold_convert (gfc_array_index_type, span);
        else
  	gcc_unreachable ();
  
*************** trans_code (gfc_code * code, tree cond)
*** 1647,1652 ****
--- 1662,1668 ----
  	  gfc_add_expr_to_block (&block, res);
  	}
  
+       gfc_current_locus = code->loc;
        gfc_set_backend_locus (&code->loc);
  
        switch (code->op)
Index: gcc/testsuite/gfortran.dg/deferred_character_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_1.f90	(working copy)
***************
*** 0 ****
--- 1,40 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR50221
+ !
+ ! Contributed by Clive Page  <clivegpage@gmail.com>
+ !            and Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+ ! This is from comment #2 by Tobias Burnus.
+ !
+ module m
+   character(len=:), save, allocatable :: str(:)
+   character(len=2), parameter :: const(3) = ["a1", "b2", "c3"]
+ end
+ 
+   use m
+   call test()
+   if(allocated(str)) deallocate(str)
+   call foo
+ contains
+   subroutine test()
+     call doit()
+ !    print *, 'strlen=',len(str),' / array size =',size(str)
+ !    print '(3a)', '>',str(1),'<'
+ !    print '(3a)', '>',str(2),'<'
+ !    print '(3a)', '>',str(3),'<'
+     if (any (str .ne. const)) call abort
+   end subroutine test
+   subroutine doit()
+     str = const
+   end subroutine doit
+   subroutine foo
+ !
+ ! This is the original PR from Clive Page
+ !
+     character(:), allocatable, dimension(:) :: array
+     array = (/'xx', 'yy', 'zz'/)
+ !    print *, 'array=', array, len(array(1)), size(array)
+     if (any (array .ne. ["xx", "yy", "zz"])) call abort
+   end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/deferred_character_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_2.f90	(working copy)
***************
*** 0 ****
--- 1,89 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR68216
+ !
+ ! Reported on clf: https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc
+ !
+ PROGRAM hello
+ !
+ ! This is based on the first testcase, from Francisco (Ayyy LMAO). Original
+ ! lines are commented out. The second testcase from this thread is acalled
+ ! at the end of the program.
+ !
+     IMPLICIT NONE
+ 
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
+     character (3), dimension (2) :: array_fijo = ["abc","def"]
+     character (100) :: buffer
+     INTEGER :: largo , cant_lineas , i
+ 
+     write (buffer, "(2a3)") array_fijo
+ 
+ !    WRITE(*,*) ' Escriba un numero para el largo de cada linea'
+ !    READ(*,*) largo
+     largo = LEN (array_fijo)
+ 
+ !    WRITE(*,*) ' Escriba la cantidad de lineas'
+ !    READ(*,*) cant_lineas
+     cant_lineas = size (array_fijo, 1)
+ 
+     ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))
+ 
+ !    WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas)
+     READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)
+ 
+ !    WRITE(*,*) 'Array guardado: '
+ !    DO i=1,cant_lineas
+ !    WRITE(*,*) array_lineas(i)
+ !    ENDDO
+      if (any (array_lineas .ne. array_fijo)) call abort
+ 
+ ! The following are additional tests beyond that of the original.
+ ! NOTE: These tests all work in 6 branch but those involving deferred length
+ ! SOURCE or MOLD do not work correctly in 5 branch because the requisite
+ ! patches to gfc_trans_allocate have not been backported.
+ !
+ ! Check that allocation with source = another deferred length is OK
+ !     allocate (array_copia(size (array_lineas, 1)), source = array_lineas)
+ !     if (any (array_copia .ne. array_fijo)) call abort
+ !     deallocate (array_lineas, array_copia)
+      deallocate (array_lineas)
+ 
+ ! Check that allocation with source = a non-deferred length is OK
+      allocate (array_lineas(size (array_fijo, 1)), source = array_fijo)
+      if (any (array_lineas .ne. array_fijo)) call abort
+      deallocate (array_lineas)
+ 
+ ! Check that allocation with MOLD = a non-deferred length is OK
+      allocate (array_copia(4), mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)])
+      if (size (array_copia, 1) .ne. 4) call abort
+      if (LEN (array_copia) .ne. 2) call abort
+ 
+ ! Check that allocation with MOLD = another deferred length is OK
+ !     allocate (array_lineas(4), mold = array_copia)
+ !     if (size (array_lineas, 1) .ne. 4) call abort
+ !     if (LEN (array_lineas) .ne. 2) call abort
+ !     deallocate (array_lineas, array_copia)
+ 
+ !    READ(*,*)
+      call testdefchar
+ contains
+      subroutine testdefchar
+ !
+ ! This is the testcase in the above thread from Blokbuster
+ !
+           implicit none
+           character(:), allocatable :: test(:)
+ 
+           allocate(character(3) :: test(2))
+           test(1) = 'abc'
+           test(2) = 'def'
+           if (any (test .ne. ['abc', 'def'])) call abort
+ 
+           test = ['aa','bb','cc']
+           if (any (test .ne. ['aa', 'bb', 'cc'])) call abort
+ 
+      end subroutine testdefchar
+ 
+ END PROGRAM
Index: gcc/testsuite/gfortran.dg/deferred_character_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_3.f90	(working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! {dg_do run }
+ !
+ ! Tests the fix for PR67674
+ !
+ ! Contributed by Kristopher Kuhlman  <kristopher.kuhlman@gmail.com>
+ !
+ program test
+   implicit none
+ 
+   type string_type
+     character(len=:), allocatable :: name
+   end type string_type
+   type(string_type), allocatable :: my_string_type
+ 
+   allocate(my_string_type)
+   allocate(character(len=0) :: my_string_type%name)
+ 
+ !  print *, 'length main program before',len(my_string_type%name)
+ 
+   call inputreadword1(my_string_type%name)
+ 
+ !  print *, 'length main program after',len(my_string_type%name)
+ !  print *, 'final result:',my_string_type%name
+   if (my_string_type%name .ne. 'here the word is finally set') call abort
+ 
+ contains
+   subroutine inputreadword1(word_intermediate)
+     character(len=:), allocatable :: word_intermediate
+ 
+ !    print *, 'length intermediate before',len(word_intermediate)
+     call inputreadword2(word_intermediate)
+ !    print *, 'length intermediate after',len(word_intermediate)
+ !    print *, word_intermediate
+ 
+   end subroutine inputreadword1
+ 
+   subroutine inputreadword2(word)
+     character(len=:), allocatable :: word
+ 
+ !    print *, 'length inner before',len(word)
+     word = 'here the word is finally set' ! want automatic reallocation to happen here
+ !    print *, 'length inner after',len(word)
+ !    print *, word
+ 
+   end subroutine inputreadword2
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_4.f90	(working copy)
***************
*** 0 ****
--- 1,30 ----
+ ! { dg-do run }
+ !
+ ! Check that PR50221 comment #4 is fixed.
+ !
+ ! Contributed by Arjen Makus  <arjen.markus895@gmail.com>
+ !
+ program chk_alloc_string
+     implicit none
+ 
+     character(len=:), dimension(:), allocatable :: strings
+     character(20) :: buffer
+     integer :: i
+ 
+     allocate( character(10):: strings(1:3) )
+ 
+     strings = [ "A   ", "C   ", "ABCD", "V   " ]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 4) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V"])) call abort
+ 
+     strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 5) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) call abort
+ 
+     write (buffer, "(5a4)") strings
+     if (buffer .ne. "A   C   ABCDV   zzzz") call abort
+ end program chk_alloc_string
Index: gcc/testsuite/gfortran.dg/deferred_character_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_5.f90	(working copy)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR63932 stays fixed.
+ !
+ ! Contributed by Valery Weber  <valeryweber@hotmail.com>
+ !
+ module mod
+   type :: t
+      character(:), allocatable :: c
+      integer :: i
+    contains
+      procedure, pass :: get
+   end type t
+   type :: u
+      character(:), allocatable :: c
+   end type u
+ contains
+   subroutine get(this, a)
+     class(t), intent(in) :: this
+     character(:), allocatable, intent(out), optional :: a
+     if (present (a)) a = this%c
+   end subroutine get
+ end module mod
+ 
+ program test
+   use mod
+   type(t) :: a
+   type(u) :: b
+   a%c = 'something'
+   call a%get (a = b%c)
+   if (b%c .ne. 'something') call abort
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_6.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_6.f90	(working copy)
***************
*** 0 ****
--- 1,54 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR66408 stays fixed.
+ !
+ ! Contributed by <werner.blokbuster@gmail.com>
+ !
+ module mytest
+ 
+     implicit none
+ 
+     type vary
+         character(:), allocatable :: string
+     end type vary
+ 
+     interface assignment(=)
+         module procedure char_eq_vary
+     end interface assignment(=)
+ 
+ contains
+ 
+     subroutine char_eq_vary(my_char,my_vary)
+         character(:), allocatable, intent(out) :: my_char
+         type(vary), intent(in) :: my_vary
+         my_char = my_vary%string
+     end subroutine char_eq_vary
+ 
+ end module mytest
+ 
+ 
+ program thistest
+ 
+     use mytest, only: vary, assignment(=)
+     implicit none
+ 
+     character(:), allocatable :: test_char
+     character(14), parameter :: str = 'example string'
+     type(vary) :: test_vary
+     type(vary) :: my_stuff
+ 
+ 
+     test_vary%string = str
+     if (test_vary%string .ne. str) call abort
+ 
+ ! This previously gave a blank string.
+     my_stuff%string = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+     test_char = test_vary
+     if (test_char .ne. str) call abort
+ 
+     my_stuff = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+ end program thistest
Index: gcc/testsuite/gfortran.dg/deferred_character_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_7.f90	(working copy)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for pr49954, in which concatenation to deferred length character
+ ! arrays, at best, did not work correctly.
+ !
+ !
+ !
+ implicit none
+   character(len=:), allocatable :: a1(:)
+   character(len=:), allocatable :: a2(:), a3(:)
+   character(len=:), allocatable :: b1
+   character(len=:), allocatable :: b2
+   character(8) :: chr = "IJKLMNOP"
+   character(48) :: buffer
+ 
+   a1 = ["ABCDEFGH","abcdefgh"]
+   a2 = "_"//a1//chr//"_"
+   if (any (a2 .ne. ["_ABCDEFGHIJKLMNOP_","_abcdefghIJKLMNOP_"])) call abort
+ 
+ ! Check that the descriptor dtype is OK - the array write needs it.
+   write (buffer, "(2a18)") a2
+   if (trim (buffer) .ne. "_ABCDEFGHIJKLMNOP__abcdefghIJKLMNOP_") call abort
+ 
+ ! Make sure scalars survived the fix!
+   b1 = "ABCDEFGH"
+   b2 = "_"//b1//chr//"_"
+   if (b2 .ne. "_ABCDEFGHIJKLMNOP_") call abort
+ 
+ ! Check the dependency is detected and dealt with by generation of a temporary.
+   a1 = "?"//a1//"?"
+   if (any (a1 .ne. ["?ABCDEFGH?","?abcdefgh?"])) call abort
+ ! With an array reference...
+   a1 = "?"//a1(1:2)//"?"
+   if (any (a1 .ne. ["??ABCDEFGH??","??abcdefgh??"])) call abort
+ !... together with a substring.
+   a1 = "?"//a1(1:1)(2:4)//"?"
+   if (any (a1 .ne. ["??AB?"])) call abort
+ contains
+ end

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Steve Kargl]

On Fri, Dec 18, 2015 at 07:12:47PM +0100, Paul Richard Thomas wrote:
> 
> I have just applied the patch to 5 branch and have found that, apart
> from two minor tweaks in trans.c, all was well. It bootstrapped
>  and regtested fine, apart from deferred_character_2.f90. In this
> latter, deferred length SOURCE and MOLD do not work because the
> requisite patches in gfc_trans_allocate were not backported.  In
> addition, I had to add explicit array specifications to the allocate
> statements.
> 
> Should I get deferred length SOURCE and MOLD to work or apply the
> attached patch as it stands? Alternatively, I could forget about 4.9
> and 5 branches and close the PRs.
> 
> I have added the ChangeLogs below.
> 

I'll review this tonight or tomorrow morning.

As to your question, I think that it is time to let 4.9 go.
AFAIK, there is going to be only one more release from the 4
branch.  Too many PRs, too few hands to fix them.  Hopefully,
major OS's will move to 5.x as the recommended gcc distro.

I think backports to the 5 branch should be done at the
disgression of the committer.  If you have cycles to burn,
backporting is up to you.  One problem with this viewpoint
is, of course, code divergence between 5-branch and trunk
makes backporting more difficult.

-- 
steve

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

Hi Steve,

The patch is almost exactly as you reviewed before. The tweaks to
trans.c came about because of other patches that prevented this one
from applying. Please concentrate on the modified testcase and let me
know if you would like me to make it work as it does in 6 branch. I
will take a quick look to see how much work is involved.

Thanks

Paul

On 18 December 2015 at 19:39, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Fri, Dec 18, 2015 at 07:12:47PM +0100, Paul Richard Thomas wrote:
>>
>> I have just applied the patch to 5 branch and have found that, apart
>> from two minor tweaks in trans.c, all was well. It bootstrapped
>>  and regtested fine, apart from deferred_character_2.f90. In this
>> latter, deferred length SOURCE and MOLD do not work because the
>> requisite patches in gfc_trans_allocate were not backported.  In
>> addition, I had to add explicit array specifications to the allocate
>> statements.
>>
>> Should I get deferred length SOURCE and MOLD to work or apply the
>> attached patch as it stands? Alternatively, I could forget about 4.9
>> and 5 branches and close the PRs.
>>
>> I have added the ChangeLogs below.
>>
>
> I'll review this tonight or tomorrow morning.
>
> As to your question, I think that it is time to let 4.9 go.
> AFAIK, there is going to be only one more release from the 4
> branch.  Too many PRs, too few hands to fix them.  Hopefully,
> major OS's will move to 5.x as the recommended gcc distro.
>
> I think backports to the 5 branch should be done at the
> disgression of the committer.  If you have cycles to burn,
> backporting is up to you.  One problem with this viewpoint
> is, of course, code divergence between 5-branch and trunk
> makes backporting more difficult.
>
> --
> steve



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

Hi Steve,

I have run out of time because I am just about to set off to the UK
for Christmas. I only have trunk installed on my laptop, although I
might just load up 5 branch. I'll be back on the 29th and will deal
with this backport then.

Cheers

Paul

On 18 December 2015 at 19:58, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Hi Steve,
>
> The patch is almost exactly as you reviewed before. The tweaks to
> trans.c came about because of other patches that prevented this one
> from applying. Please concentrate on the modified testcase and let me
> know if you would like me to make it work as it does in 6 branch. I
> will take a quick look to see how much work is involved.
>
> Thanks
>
> Paul
>
> On 18 December 2015 at 19:39, Steve Kargl
> <sgk@troutmask.apl.washington.edu> wrote:
>> On Fri, Dec 18, 2015 at 07:12:47PM +0100, Paul Richard Thomas wrote:
>>>
>>> I have just applied the patch to 5 branch and have found that, apart
>>> from two minor tweaks in trans.c, all was well. It bootstrapped
>>>  and regtested fine, apart from deferred_character_2.f90. In this
>>> latter, deferred length SOURCE and MOLD do not work because the
>>> requisite patches in gfc_trans_allocate were not backported.  In
>>> addition, I had to add explicit array specifications to the allocate
>>> statements.
>>>
>>> Should I get deferred length SOURCE and MOLD to work or apply the
>>> attached patch as it stands? Alternatively, I could forget about 4.9
>>> and 5 branches and close the PRs.
>>>
>>> I have added the ChangeLogs below.
>>>
>>
>> I'll review this tonight or tomorrow morning.
>>
>> As to your question, I think that it is time to let 4.9 go.
>> AFAIK, there is going to be only one more release from the 4
>> branch.  Too many PRs, too few hands to fix them.  Hopefully,
>> major OS's will move to 5.x as the recommended gcc distro.
>>
>> I think backports to the 5 branch should be done at the
>> disgression of the committer.  If you have cycles to burn,
>> backporting is up to you.  One problem with this viewpoint
>> is, of course, code divergence between 5-branch and trunk
>> makes backporting more difficult.
>>
>> --
>> steve
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: Ping: [Patch, fortran] Bug 68241 - [meta-bug] Deferred-length character - PRs50221, 68216, 63932, 66408, 67674 and 49954

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 5555 bytes --]

Dear All,

As promised, please find attached the version of this patch for
5-branch. The changes are small enough that I couldn't immediately see
any changes required in the text of the ChangeLog. I will look more
carefully tomorrow, add the "backported from trunk"s and the current
date. I intend to commit on Sunday evening, unless there is any
objection.

Bootstrapped and regtested in 5-branch on FC21/x86_64

Cheers

Paul

On 18 December 2015 at 19:12, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> In running through the PRs assigned to me, I realised that I have not
> closed these PRs because I had promised to see if the patch would
> apply to 4.9 and 5 branch.
>
> I have just applied the patch to 5 branch and have found that, apart
> from two minor tweaks in trans.c, all was well. It bootstrapped
>  and regtested fine, apart from deferred_character_2.f90. In this
> latter, deferred length SOURCE and MOLD do not work because the
> requisite patches in gfc_trans_allocate were not backported.  In
> addition, I had to add explicit array specifications to the allocate
> statements.
>
> Should I get deferred length SOURCE and MOLD to work or apply the
> attached patch as it stands? Alternatively, I could forget about 4.9
> and 5 branches and close the PRs.
>
> I have added the ChangeLogs below.
>
> Cheers
>
> Paul
>
> 2015-12-18  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/50221
>     PR fortran/68216
>     PR fortran/63932
>     PR fortran/66408
>     * trans_array.c (gfc_conv_scalarized_array_ref): Pass the
>     symbol decl for deferred character length array references.
>     * trans-stmt.c (gfc_trans_allocate): Keep the string lengths
>     to update deferred length character string lengths.
>     * trans-types.c (gfc_get_dtype_rank_type); Use the string
>     length of deferred character types for the dtype size.
>     * trans.c (gfc_build_array_ref): For references to deferred
>     character arrays, use the domain max value, if it is a variable
>     to set the 'span' and use pointer arithmetic for acces to the
>     element.
>     (trans_code): Set gfc_current_locus for diagnostic purposes.
>
>     PR fortran/67674
>     * trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
>     string lengths of components.
>
>     PR fortran/49954
>     * resolve.c (deferred_op_assign): New function.
>     (gfc_resolve_code): Call it.
>     * trans-array.c (concat_str_length): New function.
>     (gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
>     realloc blocks for deferred character length arrays because the
>     string length might change, even if the shape is the same. Call
>     concat_str_length to obtain the string length for concatenation
>     since it is needed to compute the lhs string length.
>     Set the descriptor dtype appropriately for the new string
>     length.
>     * trans-expr.c (gfc_trans_assignment_1): Use the rse string
>     length for all characters, other than deferred types. For
>     concatenation operators, push the rse.pre block to the inner
>     most loop so that the temporary pointer and the assignments
>     are properly placed.
>
> 2015-12-18  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/50221
>     * gfortran.dg/deferred_character_1.f90: New test.
>     * gfortran.dg/deferred_character_4.f90: New test for comment
>     #4 of the PR.
>
>     PR fortran/68216
>     * gfortran.dg/deferred_character_2.f90: New test.
>
>     PR fortran/67674
>     * gfortran.dg/deferred_character_3.f90: New test.
>
>     PR fortran/63932
>     * gfortran.dg/deferred_character_5.f90: New test.
>
>     PR fortran/66408
>     * gfortran.dg/deferred_character_6.f90: New test.
>
>     PR fortran/49954
>     * gfortran.dg/deferred_character_7.f90: New test.
>
> On 15 November 2015 at 15:13, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
>> Dear Steve,
>>
>> Thanks for the review.
>>
>> Committed as revision 230396.
>>
>> My diagnosis of the last problem that Dominique found is correct.
>> However, I have not succeeded in fixing it and so the patch was
>> committed as review. I'll just have to return to the problem this
>> evening.
>>
>> Cheers
>>
>> Paul
>>
>> On 14 November 2015 at 21:10, Steve Kargl
>> <sgk@troutmask.apl.washington.edu> wrote:
>>> On Sat, Nov 14, 2015 at 07:25:29PM +0100, Paul Richard Thomas wrote:
>>>>
>>>> Following an email from Dominique to me, I think not. In the course of
>>>> fixing PR49954, I put right the setting of the descriptor dtype. Since
>>>> this gets passed to the IO runtime, I think that this is the reason
>>>> for the difference in behaviour.
>>>>
>>>> I think that another week of effort should put right gfortran's woes
>>>> with deferred characters. As well as concatenation problems that I
>>>> think I have fixed, parentheses cause instant death :-(
>>>>
>>>
>>> Hi Paul,
>>>
>>> I built and tested on both x86_64-*-freebsd and i386-*-freebsd.
>>> All tests passed.
>>>
>>> I read through the patch did not raise any red (or what
>>> the heck is he doing here) flags.
>>>
>>> OK to commit as this is a step in the right direction in
>>> dealing with deferred character issues.
>>>
>>> --
>>> Steve
>>
>>
>>
>> --
>> Outside of a dog, a book is a man's best friend. Inside of a dog it's
>> too dark to read.
>>
>> Groucho Marx
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

[-- Attachment #2: submit5.diff --]
[-- Type: text/plain, Size: 28187 bytes --]

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 232163)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_transfer (gfc_code *code)
*** 8494,8500 ****
  	  return;
  	}
      }
!    
    if (exp->expr_type == EXPR_STRUCTURE)
      return;
  
--- 8494,8500 ----
  	  return;
  	}
      }
! 
    if (exp->expr_type == EXPR_STRUCTURE)
      return;
  
*************** generate_component_assignments (gfc_code
*** 9993,9998 ****
--- 9993,10042 ----
  }
  
  
+ /* Deferred character length assignments from an operator expression
+    require a temporary because the character length of the lhs can
+    change in the course of the assignment.  */
+ 
+ static bool
+ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
+ {
+   gfc_expr *tmp_expr;
+   gfc_code *this_code;
+ 
+   if (!((*code)->expr1->ts.type == BT_CHARACTER
+ 	 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
+ 	 && (*code)->expr2->expr_type == EXPR_OP))
+     return false;
+ 
+   if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
+     return false;
+ 
+   tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+   tmp_expr->where = (*code)->loc;
+ 
+   /* A new charlen is required to ensure that the variable string
+      length is different to that of the original lhs.  */
+   tmp_expr->ts.u.cl = gfc_get_charlen();
+   tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
+   tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
+   (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
+ 
+   tmp_expr->symtree->n.sym->ts.deferred = 1;
+ 
+   this_code = build_assignment (EXEC_ASSIGN,
+ 				(*code)->expr1,
+ 				gfc_copy_expr (tmp_expr),
+ 				NULL, NULL, (*code)->loc);
+ 
+   (*code)->expr1 = tmp_expr;
+ 
+   this_code->next = (*code)->next;
+   (*code)->next = this_code;
+ 
+   return true;
+ }
+ 
+ 
  /* Given a block of code, recursively resolve everything pointed to by this
     code block.  */
  
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10190,10195 ****
--- 10234,10244 ----
  		goto call;
  	    }
  
+ 	  /* Check for dependencies in deferred character length array
+ 	     assignments and generate a temporary, if necessary.  */
+ 	  if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
+ 	    break;
+ 
  	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
  	  if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
  	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
*************** gfc_verify_binding_labels (gfc_symbol *s
*** 10562,10568 ****
        sym->binding_label = NULL;
  
      }
!   else if (sym->attr.flavor == FL_VARIABLE && module 
  	   && (strcmp (module, gsym->mod_name) != 0
  	       || strcmp (sym->name, gsym->sym_name) != 0))
      {
--- 10611,10617 ----
        sym->binding_label = NULL;
  
      }
!   else if (sym->attr.flavor == FL_VARIABLE && module
  	   && (strcmp (module, gsym->mod_name) != 0
  	       || strcmp (sym->name, gsym->sym_name) != 0))
      {
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 232163)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3112,3118 ****
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && is_subref_array (expr))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
--- 3112,3119 ----
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && (is_subref_array (expr)
! 	       || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE)))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
*************** gfc_is_reallocatable_lhs (gfc_expr *expr
*** 8269,8274 ****
--- 8270,8344 ----
  }
  
  
+ static tree
+ concat_str_length (gfc_expr* expr)
+ {
+   tree type;
+   tree len1;
+   tree len2;
+   gfc_se se;
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
+   len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len1 == NULL_TREE)
+     {
+       if (expr->value.op.op1->expr_type == EXPR_OP)
+ 	len1 = concat_str_length (expr->value.op.op1);
+       else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
+ 	len1 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op1->value.character.length);
+       else if (expr->value.op.op1->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
+ 	  len1 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op1);
+ 	  len1 = se.string_length;
+ 	}
+     }
+ 
+   type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
+   len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+   if (len2 == NULL_TREE)
+     {
+       if (expr->value.op.op2->expr_type == EXPR_OP)
+ 	len2 = concat_str_length (expr->value.op.op2);
+       else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
+ 	len2 = build_int_cst (gfc_charlen_type_node,
+ 			expr->value.op.op2->value.character.length);
+       else if (expr->value.op.op2->ts.u.cl->length)
+ 	{
+ 	  gfc_init_se (&se, NULL);
+ 	  gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
+ 	  len2 = se.expr;
+ 	}
+       else
+ 	{
+ 	  /* Last resort!  */
+ 	  gfc_init_se (&se, NULL);
+ 	  se.want_pointer = 1;
+ 	  se.descriptor_only = 1;
+ 	  gfc_conv_expr (&se, expr->value.op.op2);
+ 	  len2 = se.string_length;
+ 	}
+     }
+ 
+   gcc_assert(len1 && len2);
+   len1 = fold_convert (gfc_charlen_type_node, len1);
+   len2 = fold_convert (gfc_charlen_type_node, len2);
+ 
+   return fold_build2_loc (input_location, PLUS_EXPR,
+ 			  gfc_charlen_type_node, len1, len2);
+ }
+ 
+ 
  /* Allocate the lhs of an assignment to an allocatable array, otherwise
     reallocate it.  */
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8366,8371 ****
--- 8436,8447 ----
    /* Allocate if data is NULL.  */
    cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));
+ 
+   if (expr1->ts.deferred)
+     cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
+   else
+     cond_null= gfc_evaluate_now (cond_null, &fblock);
+ 
    tmp = build3_v (COND_EXPR, cond_null,
  		  build1_v (GOTO_EXPR, jump_label1),
  		  build_empty_stmt (input_location));
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8454,8460 ****
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
  			  size1, size2);
!   neq_size = gfc_evaluate_now (cond, &fblock);
  
    /* Deallocation of allocatable components will have to occur on
       reallocation.  Fix the old descriptor now.  */
--- 8530,8542 ----
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
  			  size1, size2);
! 
!   /* If the lhs is deferred length, assume that the element size
!      changes and force a reallocation.  */
!   if (expr1->ts.deferred)
!     neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
!   else
!     neq_size = gfc_evaluate_now (cond, &fblock);
  
    /* Deallocation of allocatable components will have to occur on
       reallocation.  Fix the old descriptor now.  */
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8559,8564 ****
--- 8641,8652 ----
        else
  	{
  	  tmp = expr2->ts.u.cl->backend_decl;
+ 	  if (!tmp && expr2->expr_type == EXPR_OP
+ 	      && expr2->value.op.op == INTRINSIC_CONCAT)
+ 	    {
+ 	      tmp = concat_str_length (expr2);
+ 	      expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ 	    }
  	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
  	}
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8586,8591 ****
--- 8674,8695 ----
  			   size2, size_one_node);
    size2 = gfc_evaluate_now (size2, &fblock);
  
+   /* For deferred character length, the 'size' field of the dtype might
+      have changed so set the dtype.  */
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+       && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+     {
+       tree type;
+       tmp = gfc_conv_descriptor_dtype (desc);
+       if (expr2->ts.u.cl->backend_decl)
+ 	type = gfc_typenode_for_spec (&expr2->ts);
+       else
+ 	type = gfc_typenode_for_spec (&expr1->ts);
+ 
+       gfc_add_modify (&fblock, tmp,
+ 		      gfc_get_dtype_rank_type (expr1->rank,type));
+     }
+ 
    /* Realloc expression.  Note that the scalarizer uses desc.data
       in the array reference - (*desc.data)[<element>].  */
    gfc_init_block (&realloc_block);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8628,8635 ****
  			     1, size2);
    gfc_conv_descriptor_data_set (&alloc_block,
  				desc, tmp);
!   tmp = gfc_conv_descriptor_dtype (desc);
!   gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
    if ((expr1->ts.type == BT_DERIVED)
  	&& expr1->ts.u.derived->attr.alloc_comp)
      {
--- 8732,8747 ----
  			     1, size2);
    gfc_conv_descriptor_data_set (&alloc_block,
  				desc, tmp);
! 
!   /* We already set the dtype in the case of deferred character
!      length arrays.  */
!   if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
!         && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
!     {
!       tmp = gfc_conv_descriptor_dtype (desc);
!       gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
!     }
! 
    if ((expr1->ts.type == BT_DERIVED)
  	&& expr1->ts.u.derived->attr.alloc_comp)
      {
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 232163)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5343,5349 ****
  	  else
  	    {
  	      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);
  	    }
--- 5343,5350 ----
  	  else
  	    {
  	      tmp = parmse.string_length;
! 	      if (TREE_CODE (tmp) != VAR_DECL
! 		  && TREE_CODE (tmp) != COMPONENT_REF)
  		tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
  	      parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
  	    }
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 8998,9005 ****
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
    else
      string_length = NULL_TREE;
  
--- 8999,9008 ----
      }
  
    /* Stabilize a string length for temporaries.  */
!   if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred)
      string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+   else if (expr2->ts.type == BT_CHARACTER)
+     string_length = rse.string_length;
    else
      string_length = NULL_TREE;
  
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 9033,9040 ****
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.  */
!   if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
--- 9036,9049 ----
       the function call must happen before the (re)allocation of the lhs -
       otherwise the character length of the result is not known.
       NOTE: This relies on having the exact dependence of the length type
!      parameter available to the caller; gfortran saves it in the .mod files.
!      NOTE ALSO: The concatenation operation generates a temporary pointer,
!      whose allocation must go to the innermost loop.  */
!   if (flag_realloc_lhs
!       && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
!       && !(lss != gfc_ss_terminator
! 	   && expr2->expr_type == EXPR_OP
! 	   && expr2->value.op.op == INTRINSIC_CONCAT))
      gfc_add_block_to_block (&block, &rse.pre);
  
    /* Nullify the allocatable components corresponding to those of the lhs
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 232163)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5119,5124 ****
--- 5119,5125 ----
    tree label_finish;
    tree memsz;
    tree al_vptr, al_len;
+   tree def_str_len = NULL_TREE;
    /* If an expr3 is present, then store the tree for accessing its
       _vptr, and _len components in the variables, respectively.  The
       element size, i.e. _vptr%size, is stored in expr3_esize.  Any of
*************** gfc_trans_allocate (gfc_code * code)
*** 5381,5386 ****
--- 5382,5388 ----
  	  expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
  					 TREE_TYPE (se_sz.expr),
  					 tmp, se_sz.expr);
+ 	  def_str_len = gfc_evaluate_now (se_sz.expr, &block);
  	}
      }
  
*************** gfc_trans_allocate (gfc_code * code)
*** 5432,5437 ****
--- 5434,5450 ----
  
        se.want_pointer = 1;
        se.descriptor_only = 1;
+ 
+       if (expr->ts.type == BT_CHARACTER
+ 	  && expr->ts.deferred
+ 	  && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL
+ 	  && def_str_len != NULL_TREE)
+ 	{
+ 	  tmp = expr->ts.u.cl->backend_decl;
+ 	  gfc_add_modify (&block, tmp,
+ 			  fold_convert (TREE_TYPE (tmp), def_str_len));
+ 	}
+ 
        gfc_conv_expr (&se, expr);
        if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
  	/* se.string_length now stores the .string_length variable of expr
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 232163)
--- gcc/fortran/trans.c	(working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 344,349 ****
--- 344,361 ----
  
    type = TREE_TYPE (type);
  
+   /* Use pointer arithmetic for deferred character length array
+      references.  */
+   if (type && TREE_CODE (type) == ARRAY_TYPE
+       && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
+       && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL
+       && decl
+       && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ 					== DECL_CONTEXT (decl))
+     span = TYPE_MAXVAL (TYPE_DOMAIN (type));
+   else
+     span = NULL_TREE;
+ 
    if (DECL_P (base))
      TREE_ADDRESSABLE (base) = 1;
  
*************** gfc_build_array_ref (tree base, tree off
*** 358,364 ****
  		 || TREE_CODE (decl) == PARM_DECL)
  	&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	      && !integer_zerop (GFC_DECL_SPAN(decl)))
! 	   || GFC_DECL_CLASS (decl)))
      {
        if (GFC_DECL_CLASS (decl))
  	{
--- 370,377 ----
  		 || TREE_CODE (decl) == PARM_DECL)
  	&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
  	      && !integer_zerop (GFC_DECL_SPAN(decl)))
! 	   || GFC_DECL_CLASS (decl)
! 	   || span != NULL_TREE))
      {
        if (GFC_DECL_CLASS (decl))
  	{
*************** gfc_build_array_ref (tree base, tree off
*** 377,382 ****
--- 390,397 ----
  	}
        else if (GFC_DECL_SUBREF_ARRAY_P (decl))
  	span = GFC_DECL_SPAN(decl);
+       else if (span)
+ 	span = fold_convert (gfc_array_index_type, span);
        else
  	gcc_unreachable ();
  
*************** trans_code (gfc_code * code, tree cond)
*** 1667,1672 ****
--- 1682,1688 ----
  	  gfc_add_expr_to_block (&block, res);
  	}
  
+       gfc_current_locus = code->loc;
        gfc_set_backend_locus (&code->loc);
  
        switch (code->op)
Index: gcc/testsuite/gfortran.dg/deferred_character_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_1.f90	(working copy)
***************
*** 0 ****
--- 1,40 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR50221
+ !
+ ! Contributed by Clive Page  <clivegpage@gmail.com>
+ !            and Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+ ! This is from comment #2 by Tobias Burnus.
+ !
+ module m
+   character(len=:), save, allocatable :: str(:)
+   character(len=2), parameter :: const(3) = ["a1", "b2", "c3"]
+ end
+ 
+   use m
+   call test()
+   if(allocated(str)) deallocate(str)
+   call foo
+ contains
+   subroutine test()
+     call doit()
+ !    print *, 'strlen=',len(str),' / array size =',size(str)
+ !    print '(3a)', '>',str(1),'<'
+ !    print '(3a)', '>',str(2),'<'
+ !    print '(3a)', '>',str(3),'<'
+     if (any (str .ne. const)) call abort
+   end subroutine test
+   subroutine doit()
+     str = const
+   end subroutine doit
+   subroutine foo
+ !
+ ! This is the original PR from Clive Page
+ !
+     character(:), allocatable, dimension(:) :: array
+     array = (/'xx', 'yy', 'zz'/)
+ !    print *, 'array=', array, len(array(1)), size(array)
+     if (any (array .ne. ["xx", "yy", "zz"])) call abort
+   end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/deferred_character_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_2.f90	(working copy)
***************
*** 0 ****
--- 1,89 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR68216
+ !
+ ! Reported on clf: https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc
+ !
+ PROGRAM hello
+ !
+ ! This is based on the first testcase, from Francisco (Ayyy LMAO). Original
+ ! lines are commented out. The second testcase from this thread is acalled
+ ! at the end of the program.
+ !
+     IMPLICIT NONE
+ 
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
+     CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
+     character (3), dimension (2) :: array_fijo = ["abc","def"]
+     character (100) :: buffer
+     INTEGER :: largo , cant_lineas , i
+ 
+     write (buffer, "(2a3)") array_fijo
+ 
+ !    WRITE(*,*) ' Escriba un numero para el largo de cada linea'
+ !    READ(*,*) largo
+     largo = LEN (array_fijo)
+ 
+ !    WRITE(*,*) ' Escriba la cantidad de lineas'
+ !    READ(*,*) cant_lineas
+     cant_lineas = size (array_fijo, 1)
+ 
+     ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))
+ 
+ !    WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas)
+     READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)
+ 
+ !    WRITE(*,*) 'Array guardado: '
+ !    DO i=1,cant_lineas
+ !    WRITE(*,*) array_lineas(i)
+ !    ENDDO
+      if (any (array_lineas .ne. array_fijo)) call abort
+ 
+ ! The following are additional tests beyond that of the original.
+ ! NOTE: These tests all work in 6 branch but those involving deferred length
+ ! SOURCE or MOLD do not work correctly in 5 branch because the requisite
+ ! patches to gfc_trans_allocate have not been backported.
+ !
+ ! Check that allocation with source = another deferred length is OK
+ !     allocate (array_copia(size (array_lineas, 1)), source = array_lineas)
+ !     if (any (array_copia .ne. array_fijo)) call abort
+ !     deallocate (array_lineas, array_copia)
+      deallocate (array_lineas)
+ 
+ ! Check that allocation with source = a non-deferred length is OK
+      allocate (array_lineas(size (array_fijo, 1)), source = array_fijo)
+      if (any (array_lineas .ne. array_fijo)) call abort
+      deallocate (array_lineas)
+ 
+ ! Check that allocation with MOLD = a non-deferred length is OK
+      allocate (array_copia(4), mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)])
+      if (size (array_copia, 1) .ne. 4) call abort
+      if (LEN (array_copia) .ne. 2) call abort
+ 
+ ! Check that allocation with MOLD = another deferred length is OK
+ !     allocate (array_lineas(4), mold = array_copia)
+ !     if (size (array_lineas, 1) .ne. 4) call abort
+ !     if (LEN (array_lineas) .ne. 2) call abort
+ !     deallocate (array_lineas, array_copia)
+ 
+ !    READ(*,*)
+      call testdefchar
+ contains
+      subroutine testdefchar
+ !
+ ! This is the testcase in the above thread from Blokbuster
+ !
+           implicit none
+           character(:), allocatable :: test(:)
+ 
+           allocate(character(3) :: test(2))
+           test(1) = 'abc'
+           test(2) = 'def'
+           if (any (test .ne. ['abc', 'def'])) call abort
+ 
+           test = ['aa','bb','cc']
+           if (any (test .ne. ['aa', 'bb', 'cc'])) call abort
+ 
+      end subroutine testdefchar
+ 
+ END PROGRAM
Index: gcc/testsuite/gfortran.dg/deferred_character_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_3.f90	(working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! {dg_do run }
+ !
+ ! Tests the fix for PR67674
+ !
+ ! Contributed by Kristopher Kuhlman  <kristopher.kuhlman@gmail.com>
+ !
+ program test
+   implicit none
+ 
+   type string_type
+     character(len=:), allocatable :: name
+   end type string_type
+   type(string_type), allocatable :: my_string_type
+ 
+   allocate(my_string_type)
+   allocate(character(len=0) :: my_string_type%name)
+ 
+ !  print *, 'length main program before',len(my_string_type%name)
+ 
+   call inputreadword1(my_string_type%name)
+ 
+ !  print *, 'length main program after',len(my_string_type%name)
+ !  print *, 'final result:',my_string_type%name
+   if (my_string_type%name .ne. 'here the word is finally set') call abort
+ 
+ contains
+   subroutine inputreadword1(word_intermediate)
+     character(len=:), allocatable :: word_intermediate
+ 
+ !    print *, 'length intermediate before',len(word_intermediate)
+     call inputreadword2(word_intermediate)
+ !    print *, 'length intermediate after',len(word_intermediate)
+ !    print *, word_intermediate
+ 
+   end subroutine inputreadword1
+ 
+   subroutine inputreadword2(word)
+     character(len=:), allocatable :: word
+ 
+ !    print *, 'length inner before',len(word)
+     word = 'here the word is finally set' ! want automatic reallocation to happen here
+ !    print *, 'length inner after',len(word)
+ !    print *, word
+ 
+   end subroutine inputreadword2
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_4.f90	(working copy)
***************
*** 0 ****
--- 1,30 ----
+ ! { dg-do run }
+ !
+ ! Check that PR50221 comment #4 is fixed.
+ !
+ ! Contributed by Arjen Makus  <arjen.markus895@gmail.com>
+ !
+ program chk_alloc_string
+     implicit none
+ 
+     character(len=:), dimension(:), allocatable :: strings
+     character(20) :: buffer
+     integer :: i
+ 
+     allocate( character(10):: strings(1:3) )
+ 
+     strings = [ "A   ", "C   ", "ABCD", "V   " ]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 4) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V"])) call abort
+ 
+     strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
+ 
+     if (len(strings) .ne. 4) call abort
+     if (size(strings, 1) .ne. 5) call abort
+     if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) call abort
+ 
+     write (buffer, "(5a4)") strings
+     if (buffer .ne. "A   C   ABCDV   zzzz") call abort
+ end program chk_alloc_string
Index: gcc/testsuite/gfortran.dg/deferred_character_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_5.f90	(working copy)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR63932 stays fixed.
+ !
+ ! Contributed by Valery Weber  <valeryweber@hotmail.com>
+ !
+ module mod
+   type :: t
+      character(:), allocatable :: c
+      integer :: i
+    contains
+      procedure, pass :: get
+   end type t
+   type :: u
+      character(:), allocatable :: c
+   end type u
+ contains
+   subroutine get(this, a)
+     class(t), intent(in) :: this
+     character(:), allocatable, intent(out), optional :: a
+     if (present (a)) a = this%c
+   end subroutine get
+ end module mod
+ 
+ program test
+   use mod
+   type(t) :: a
+   type(u) :: b
+   a%c = 'something'
+   call a%get (a = b%c)
+   if (b%c .ne. 'something') call abort
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_6.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_6.f90	(working copy)
***************
*** 0 ****
--- 1,54 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR66408 stays fixed.
+ !
+ ! Contributed by <werner.blokbuster@gmail.com>
+ !
+ module mytest
+ 
+     implicit none
+ 
+     type vary
+         character(:), allocatable :: string
+     end type vary
+ 
+     interface assignment(=)
+         module procedure char_eq_vary
+     end interface assignment(=)
+ 
+ contains
+ 
+     subroutine char_eq_vary(my_char,my_vary)
+         character(:), allocatable, intent(out) :: my_char
+         type(vary), intent(in) :: my_vary
+         my_char = my_vary%string
+     end subroutine char_eq_vary
+ 
+ end module mytest
+ 
+ 
+ program thistest
+ 
+     use mytest, only: vary, assignment(=)
+     implicit none
+ 
+     character(:), allocatable :: test_char
+     character(14), parameter :: str = 'example string'
+     type(vary) :: test_vary
+     type(vary) :: my_stuff
+ 
+ 
+     test_vary%string = str
+     if (test_vary%string .ne. str) call abort
+ 
+ ! This previously gave a blank string.
+     my_stuff%string = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+     test_char = test_vary
+     if (test_char .ne. str) call abort
+ 
+     my_stuff = test_vary
+     if (my_stuff%string .ne. str) call abort
+ 
+ end program thistest
Index: gcc/testsuite/gfortran.dg/deferred_character_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_7.f90	(working copy)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for pr49954, in which concatenation to deferred length character
+ ! arrays, at best, did not work correctly.
+ !
+ !
+ !
+ implicit none
+   character(len=:), allocatable :: a1(:)
+   character(len=:), allocatable :: a2(:), a3(:)
+   character(len=:), allocatable :: b1
+   character(len=:), allocatable :: b2
+   character(8) :: chr = "IJKLMNOP"
+   character(48) :: buffer
+ 
+   a1 = ["ABCDEFGH","abcdefgh"]
+   a2 = "_"//a1//chr//"_"
+   if (any (a2 .ne. ["_ABCDEFGHIJKLMNOP_","_abcdefghIJKLMNOP_"])) call abort
+ 
+ ! Check that the descriptor dtype is OK - the array write needs it.
+   write (buffer, "(2a18)") a2
+   if (trim (buffer) .ne. "_ABCDEFGHIJKLMNOP__abcdefghIJKLMNOP_") call abort
+ 
+ ! Make sure scalars survived the fix!
+   b1 = "ABCDEFGH"
+   b2 = "_"//b1//chr//"_"
+   if (b2 .ne. "_ABCDEFGHIJKLMNOP_") call abort
+ 
+ ! Check the dependency is detected and dealt with by generation of a temporary.
+   a1 = "?"//a1//"?"
+   if (any (a1 .ne. ["?ABCDEFGH?","?abcdefgh?"])) call abort
+ ! With an array reference...
+   a1 = "?"//a1(1:2)//"?"
+   if (any (a1 .ne. ["??ABCDEFGH??","??abcdefgh??"])) call abort
+ !... together with a substring.
+   a1 = "?"//a1(1:1)(2:4)//"?"
+   if (any (a1 .ne. ["??AB?"])) call abort
+ contains
+ end