[Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Paul Thomas]

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

:ADDPATCH fortran:

This patch removes some kludges for character expressions from 
translation and adds a comprehensive fix for the remaining character 
problems to resolution.  The latter, in principle, ensures that a 
character expression also has a character length expression.  These are 
then translated using gfc_trans_init_string_length, which has been 
renamed to gfc_conv_string_length, both to reflect the convention 
described in trans.c and its more general use.

The development relative to the version of 20070615 is that the final 
test in character_length_7.f90 is fixed and the extraneous code removed 
from trans-array.c and trans-expr.c.

I am certain that were I to say that this is an end to this kind of bug, 
all hell would break loose :-)   However, the patch is a step in that 
direction......

The testcases are based on the reporters'.

Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?

Paul

2007-08-29  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/31879
    PR fortran/31197
    PR fortran/31258
    PR fortran/32703
    * gfortran.h : Add prototype for gfc_resolve_substring_charlen.
    * resolve.c (gfc_resolve_substring_charlen): New function.
    (resolve_ref): Call gfc_resolve_substring_charlen.
    (gfc_resolve_character_operator): New function.
    (gfc_resolve_expr): Call the new functions in cases where the
    character length is missing.
    * iresolve.c (cshift, eoshift, merge, pack, reshape, spread,
    transpose, unpack): Call gfc_resolve_substring_charlen for
    source expressions that are character and have a reference.
    * trans.h (gfc_trans_init_string_length) Change name to
    gfc_conv_string_length; modify references in trans-expr.c,
    trans-array.c and trans-decl.c.
    * trans-expr.c (gfc_trans_string_length): Handle case of no
    backend_decl.
    (gfc_conv_aliased_arg): Remove code for treating substrings
    and replace with call to gfc_trans_string_length.
    * trans-array.c (gfc_conv_expr_descriptor): Remove code for
    treating strings and call gfc_trans_string_length instead.

2007-08-29  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/31879
    * gfortran.dg/char_length_7.f90: New test.
    * gfortran.dg/char_assign_1.f90: Add extra warning.

    PR fortran/31197
    PR fortran/31258
    * gfortran.dg/char_length_8.f90: New test.


[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 24435 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 127610)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 220,229 ****
     value.  */
  
  void
! gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
  {
    gfc_se se;
-   tree tmp;
  
    gfc_init_se (&se, NULL);
    gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
--- 220,228 ----
     value.  */
  
  void
! gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
  {
    gfc_se se;
  
    gfc_init_se (&se, NULL);
    gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
*************** gfc_trans_init_string_length (gfc_charle
*** 231,238 ****
  			 build_int_cst (gfc_charlen_type_node, 0));
    gfc_add_block_to_block (pblock, &se.pre);
  
!   tmp = cl->backend_decl;
!   gfc_add_modify_expr (pblock, tmp, se.expr);
  }
  
  
--- 230,239 ----
  			 build_int_cst (gfc_charlen_type_node, 0));
    gfc_add_block_to_block (pblock, &se.pre);
  
!   if (cl->backend_decl)
!     gfc_add_modify_expr (pblock, cl->backend_decl, se.expr);
!   else
!     cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
  }
  
  
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1823,1828 ****
--- 1824,1832 ----
    gfc_conv_ss_startstride (&loop);
  
    /* Build an ss for the temporary.  */
+   if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+     gfc_conv_string_length (expr->ts.cl, &parmse->pre);
+ 
    base_type = gfc_typenode_for_spec (&expr->ts);
    if (GFC_ARRAY_TYPE_P (base_type)
  		|| GFC_DESCRIPTOR_TYPE_P (base_type))
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1833,1871 ****
    loop.temp_ss->data.temp.type = base_type;
  
    if (expr->ts.type == BT_CHARACTER)
!     {
!       gfc_ref *char_ref = expr->ref;
! 
!       for (; char_ref; char_ref = char_ref->next)
! 	if (char_ref->type == REF_SUBSTRING)
! 	  {
! 	    gfc_se tmp_se;
! 
! 	    expr->ts.cl = gfc_get_charlen ();
! 	    expr->ts.cl->next = char_ref->u.ss.length->next;
! 	    char_ref->u.ss.length->next = expr->ts.cl;
! 
! 	    gfc_init_se (&tmp_se, NULL);
! 	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
! 				gfc_array_index_type);
! 	    tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
! 			       tmp_se.expr, gfc_index_one_node);
! 	    tmp = gfc_evaluate_now (tmp, &parmse->pre);
! 	    gfc_init_se (&tmp_se, NULL);
! 	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
! 				gfc_array_index_type);
! 	    tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
! 			       tmp, tmp_se.expr);
! 	    tmp = fold_convert (gfc_charlen_type_node, tmp);
! 	    expr->ts.cl->backend_decl = tmp;
! 
! 	    break;
! 	  }
!       loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
!       loop.temp_ss->string_length = expr->ts.cl->backend_decl;
!     }
  
    loop.temp_ss->data.temp.dimen = loop.dimen;
    loop.temp_ss->next = gfc_ss_terminator;
  
--- 1837,1847 ----
    loop.temp_ss->data.temp.type = base_type;
  
    if (expr->ts.type == BT_CHARACTER)
!     loop.temp_ss->string_length = expr->ts.cl->backend_decl;
!   else
!     loop.temp_ss->string_length = NULL;
  
+   parmse->string_length = loop.temp_ss->string_length;
    loop.temp_ss->data.temp.dimen = loop.dimen;
    loop.temp_ss->next = gfc_ss_terminator;
  
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2279,2286 ****
  		  && fsym->as->type != AS_ASSUMED_SHAPE;
  	      f = f || !sym->attr.always_explicit;
  
! 	      if (e->expr_type == EXPR_VARIABLE
! 		    && is_aliased_array (e))
  		/* The actual argument is a component reference to an
  		   array of derived types.  In this case, the argument
  		   is converted to a temporary, which is passed and then
--- 2255,2261 ----
  		  && fsym->as->type != AS_ASSUMED_SHAPE;
  	      f = f || !sym->attr.always_explicit;
  
! 	      if (e->expr_type == EXPR_VARIABLE && is_aliased_array (e))
  		/* The actual argument is a component reference to an
  		   array of derived types.  In this case, the argument
  		   is converted to a temporary, which is passed and then
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 127610)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_trans_auto_array_allocation (tree de
*** 3927,3933 ****
    if (sym->ts.type == BT_CHARACTER
        && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_trans_init_string_length (sym->ts.cl, &block);
  
        gfc_trans_vla_type_sizes (sym, &block);
  
--- 3927,3933 ----
    if (sym->ts.type == BT_CHARACTER
        && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_conv_string_length (sym->ts.cl, &block);
  
        gfc_trans_vla_type_sizes (sym, &block);
  
*************** gfc_trans_auto_array_allocation (tree de
*** 3951,3957 ****
  
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
!     gfc_trans_init_string_length (sym->ts.cl, &block);
  
    size = gfc_trans_array_bounds (type, sym, &offset, &block);
  
--- 3951,3957 ----
  
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
!     gfc_conv_string_length (sym->ts.cl, &block);
  
    size = gfc_trans_array_bounds (type, sym, &offset, &block);
  
*************** gfc_trans_g77_array (gfc_symbol * sym, t
*** 4017,4023 ****
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_trans_init_string_length (sym->ts.cl, &block);
  
    /* Evaluate the bounds of the array.  */
    gfc_trans_array_bounds (type, sym, &offset, &block);
--- 4017,4023 ----
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_conv_string_length (sym->ts.cl, &block);
  
    /* Evaluate the bounds of the array.  */
    gfc_trans_array_bounds (type, sym, &offset, &block);
*************** gfc_trans_dummy_array_bias (gfc_symbol *
*** 4109,4115 ****
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_trans_init_string_length (sym->ts.cl, &block);
  
    checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
  
--- 4109,4115 ----
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_conv_string_length (sym->ts.cl, &block);
  
    checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
  
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4548,4610 ****
        loop.temp_ss = gfc_get_ss ();
        loop.temp_ss->type = GFC_SS_TEMP;
        loop.temp_ss->next = gfc_ss_terminator;
        if (expr->ts.type == BT_CHARACTER)
! 	{
! 	  if (expr->ts.cl == NULL)
! 	    {
! 	      /* This had better be a substring reference!  */
! 	      gfc_ref *char_ref = expr->ref;
! 	      for (; char_ref; char_ref = char_ref->next)
! 		if (char_ref->type == REF_SUBSTRING)
! 		  {
! 		    mpz_t char_len;
! 		    expr->ts.cl = gfc_get_charlen ();
! 		    expr->ts.cl->next = char_ref->u.ss.length->next;
! 		    char_ref->u.ss.length->next = expr->ts.cl;
! 
! 		    mpz_init_set_ui (char_len, 1);
! 		    mpz_add (char_len, char_len,
! 			     char_ref->u.ss.end->value.integer);
! 		    mpz_sub (char_len, char_len,
! 			     char_ref->u.ss.start->value.integer);
! 		    expr->ts.cl->backend_decl
! 			= gfc_conv_mpz_to_tree (char_len,
! 					gfc_default_character_kind);
! 		    /* Cast is necessary for *-charlen refs.  */
! 		    expr->ts.cl->backend_decl
! 			= convert (gfc_charlen_type_node,
! 				   expr->ts.cl->backend_decl);
! 		    mpz_clear (char_len);
! 		      break;
! 		  }
! 	      gcc_assert (char_ref != NULL);
! 	      loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
! 	      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! 	    }
! 	  else if (expr->ts.cl->length
! 		     && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
! 	    {
! 	      gfc_conv_const_charlen (expr->ts.cl);
! 	      loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
! 	      loop.temp_ss->string_length
! 		= TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
! 	    }
! 	  else
! 	    {
! 	      loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
! 	      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! 	    }
! 	  se->string_length = loop.temp_ss->string_length;
! 	}
        else
! 	{
! 	  loop.temp_ss->data.temp.type
! 	    = gfc_typenode_for_spec (&expr->ts);
! 	  loop.temp_ss->string_length = NULL;
! 	}
        loop.temp_ss->data.temp.dimen = loop.dimen;
        gfc_add_ss_to_loop (&loop, loop.temp_ss);
      }
--- 4548,4565 ----
        loop.temp_ss = gfc_get_ss ();
        loop.temp_ss->type = GFC_SS_TEMP;
        loop.temp_ss->next = gfc_ss_terminator;
+ 
+       if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+ 	gfc_conv_string_length (expr->ts.cl, &se->pre);
+ 
+       loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+ 
        if (expr->ts.type == BT_CHARACTER)
! 	loop.temp_ss->string_length = expr->ts.cl->backend_decl;
        else
! 	loop.temp_ss->string_length = NULL;
! 
!       se->string_length = loop.temp_ss->string_length;
        loop.temp_ss->data.temp.dimen = loop.dimen;
        gfc_add_ss_to_loop (&loop, loop.temp_ss);
      }
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 5337,5343 ****
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_trans_init_string_length (sym->ts.cl, &fnblock);
        gfc_trans_vla_type_sizes (sym, &fnblock);
      }
  
--- 5292,5298 ----
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_conv_string_length (sym->ts.cl, &fnblock);
        gfc_trans_vla_type_sizes (sym, &fnblock);
      }
  
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 127610)
--- gcc/fortran/gfortran.h	(working copy)
*************** try gfc_resolve_iterator (gfc_iterator *
*** 2268,2273 ****
--- 2268,2274 ----
  try gfc_resolve_index (gfc_expr *, int);
  try gfc_resolve_dim_arg (gfc_expr *);
  int gfc_is_formal_arg (void);
+ void gfc_resolve_substring_charlen (gfc_expr *);
  match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
  
  
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 127610)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_conv_string_tmp (gfc_se *, tree
*** 340,346 ****
  /* Get the string length variable belonging to an expression.  */
  tree gfc_get_expr_charlen (gfc_expr *);
  /* Initialize a string length variable.  */
! void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
  /* Ensure type sizes can be gimplified.  */
  void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
  
--- 340,346 ----
  /* Get the string length variable belonging to an expression.  */
  tree gfc_get_expr_charlen (gfc_expr *);
  /* Initialize a string length variable.  */
! void gfc_conv_string_length (gfc_charlen *, stmtblock_t *);
  /* Ensure type sizes can be gimplified.  */
  void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
  
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 127610)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_substring (gfc_ref *ref)
*** 3531,3536 ****
--- 3531,3598 ----
  }
  
  
+ /* This function supplies missing substring charlens.  */
+ 
+ void
+ gfc_resolve_substring_charlen (gfc_expr *e)
+ {
+   gfc_ref *char_ref = e->ref;
+   gfc_expr *start, *end;
+ 
+   for (; char_ref; char_ref = char_ref->next)
+     if (char_ref->type == REF_SUBSTRING)
+       break;
+ 
+   if (!char_ref)
+     return;
+ 
+   if (e->ts.cl)
+     {
+       if (e->ts.cl->length)
+ 	gfc_free_expr (e->ts.cl->length);
+       else if (e->expr_type == EXPR_VARIABLE
+ 		 && e->symtree->n.sym->attr.dummy)
+ 	return;
+     }
+ 
+   e->ts.type = BT_CHARACTER;
+   e->ts.kind = gfc_default_character_kind;
+ 
+   if (!e->ts.cl)
+     {
+       e->ts.cl = gfc_get_charlen ();
+       e->ts.cl->next = gfc_current_ns->cl_list;
+       gfc_current_ns->cl_list = e->ts.cl;
+     }
+ 
+   if (char_ref->u.ss.start)
+     start = gfc_copy_expr (char_ref->u.ss.start);
+   else
+     start = gfc_int_expr (1);
+ 
+   if (char_ref->u.ss.end)
+     end = gfc_copy_expr (char_ref->u.ss.end);
+   else if (e->expr_type == EXPR_VARIABLE)
+     end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
+   else
+     end = NULL;
+ 
+   if (!start || !end)
+     return;
+ 
+   /* Length = (end - start +1).  */
+   e->ts.cl->length = gfc_subtract (end, start);
+   e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
+ 
+   e->ts.cl->length->ts.type = BT_INTEGER;
+   e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+ 
+   /* Make sure that the length is simplified.  */
+   gfc_simplify_expr (e->ts.cl->length, 0);
+   gfc_resolve_expr (e->ts.cl->length);
+ }
+ 
+ 
  /* Resolve subtype references.  */
  
  static try
*************** check_host_association (gfc_expr *e)
*** 3904,3909 ****
--- 3966,4008 ----
  }
  
  
+ static void
+ gfc_resolve_character_operator (gfc_expr *e)
+ {
+   gfc_expr *op1 = e->value.op.op1;
+   gfc_expr *op2 = e->value.op.op2;
+   gfc_expr *e1 = NULL;
+   gfc_expr *e2 = NULL;
+ 
+   gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
+ 
+   if (op1->ts.cl && op1->ts.cl->length)
+     e1 = gfc_copy_expr (op1->ts.cl->length);
+   else if (op1->expr_type == EXPR_CONSTANT)
+     e1 = gfc_int_expr (op1->value.character.length);
+ 
+   if (op2->ts.cl && op2->ts.cl->length)
+     e2 = gfc_copy_expr (op2->ts.cl->length);
+   else if (op2->expr_type == EXPR_CONSTANT)
+     e2 = gfc_int_expr (op2->value.character.length);
+ 
+   e->ts.cl = gfc_get_charlen ();
+   e->ts.cl->next = gfc_current_ns->cl_list;
+   gfc_current_ns->cl_list = e->ts.cl;
+ 
+   if (!e1 || !e2)
+     return;
+ 
+   e->ts.cl->length = gfc_add (e1, e2);
+   e->ts.cl->length->ts.type = BT_INTEGER;
+   e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+   gfc_simplify_expr (e->ts.cl->length, 0);
+   gfc_resolve_expr (e->ts.cl->length);
+ 
+   return;
+ }
+ 
+ 
  /* Resolve an expression.  That is, make sure that types of operands agree
     with their operators, intrinsic operators are converted to function calls
     for overloaded types and unresolved function references are resolved.  */
*************** gfc_resolve_expr (gfc_expr *e)
*** 3933,3938 ****
--- 4032,4041 ----
  	  if (t == SUCCESS)
  	    expression_rank (e);
  	}
+ 
+       if (e->ts.type && e->ref && e->ref->type != REF_SUBSTRING)
+ 	gfc_resolve_substring_charlen (e);
+ 
        break;
  
      case EXPR_SUBSTRING:
*************** gfc_resolve_expr (gfc_expr *e)
*** 3981,3986 ****
--- 4084,4111 ----
        gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
      }
  
+   if (e->ts.type == BT_CHARACTER && !e->ts.cl)
+     {
+       /* The cases fall through so that changes in expression type
+ 	 and the need for multiple fixes are picked up.  */
+       switch (e->expr_type)
+ 	{
+ 	case EXPR_OP:
+ 	  gfc_resolve_character_operator (e);
+ 
+ 	case EXPR_ARRAY:
+ 	  if (e->expr_type == EXPR_ARRAY)
+ 	    gfc_resolve_character_array_constructor (e);
+ 
+ 	case EXPR_SUBSTRING:
+ 	  if (!e->ts.cl && e->ref)
+ 	    gfc_resolve_substring_charlen (e);
+ 
+ 	default:
+ 	  break;
+ 	}
+     }
+ 
    return t;
  }
  
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c	(revision 127610)
--- gcc/fortran/iresolve.c	(working copy)
*************** gfc_resolve_cshift (gfc_expr *f, gfc_exp
*** 548,553 ****
--- 548,556 ----
  {
    int n;
  
+   if (array->ts.type == BT_CHARACTER && array->ref)
+     gfc_resolve_substring_charlen (array);
+ 
    f->ts = array->ts;
    f->rank = array->rank;
    f->shape = gfc_copy_shape (array->shape, array->rank);
*************** gfc_resolve_eoshift (gfc_expr *f, gfc_ex
*** 668,673 ****
--- 671,679 ----
  {
    int n;
  
+   if (array->ts.type == BT_CHARACTER && array->ref)
+     gfc_resolve_substring_charlen (array);
+ 
    f->ts = array->ts;
    f->rank = array->rank;
    f->shape = gfc_copy_shape (array->shape, array->rank);
*************** gfc_resolve_merge (gfc_expr *f, gfc_expr
*** 1378,1383 ****
--- 1384,1395 ----
  		   gfc_expr *fsource ATTRIBUTE_UNUSED,
  		   gfc_expr *mask ATTRIBUTE_UNUSED)
  {
+   if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+     gfc_resolve_substring_charlen (tsource);
+ 
+   if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+     gfc_resolve_substring_charlen (fsource);
+ 
    if (tsource->ts.type == BT_CHARACTER)
      check_charlen_present (tsource);
  
*************** void
*** 1586,1591 ****
--- 1598,1606 ----
  gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
  		  gfc_expr *vector ATTRIBUTE_UNUSED)
  {
+   if (array->ts.type == BT_CHARACTER && array->ref)
+     gfc_resolve_substring_charlen (array);
+ 
    f->ts = array->ts;
    f->rank = 1;
  
*************** gfc_resolve_reshape (gfc_expr *f, gfc_ex
*** 1689,1694 ****
--- 1704,1712 ----
    int kind;
    int i;
  
+   if (source->ts.type == BT_CHARACTER && source->ref)
+     gfc_resolve_substring_charlen (source);
+ 
    f->ts = source->ts;
  
    gfc_array_size (shape, &rank);
*************** void
*** 1980,1985 ****
--- 1998,2006 ----
  gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
  		    gfc_expr *ncopies)
  {
+   if (source->ts.type == BT_CHARACTER && source->ref)
+     gfc_resolve_substring_charlen (source);
+ 
    if (source->ts.type == BT_CHARACTER)
      check_charlen_present (source);
  
*************** gfc_resolve_transfer (gfc_expr *f, gfc_e
*** 2254,2259 ****
--- 2275,2284 ----
  void
  gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
  {
+ 
+   if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+     gfc_resolve_substring_charlen (matrix);
+ 
    f->ts = matrix->ts;
    f->rank = 2;
    if (matrix->shape)
*************** void
*** 2380,2385 ****
--- 2405,2413 ----
  gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
  		    gfc_expr *field ATTRIBUTE_UNUSED)
  {
+   if (vector->ts.type == BT_CHARACTER && vector->ref)
+     gfc_resolve_substring_charlen (vector);
+ 
    f->ts = vector->ts;
    f->rank = mask->rank;
    resolve_mask_arg (mask);
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 127610)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_trans_dummy_character (gfc_symbol *s
*** 2420,2426 ****
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_trans_init_string_length (cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
--- 2420,2426 ----
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_conv_string_length (cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
*************** gfc_trans_auto_character_variable (gfc_s
*** 2444,2450 ****
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_trans_init_string_length (sym->ts.cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
--- 2444,2450 ----
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_conv_string_length (sym->ts.cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
Index: gcc/testsuite/gfortran.dg/char_length_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_length_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/char_length_7.f90	(revision 0)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ ! Test the fix for PR31879 in which the concatenation operators below
+ ! would cause ICEs because the character lengths were never resolved.
+ !
+ ! Contributed by Vivek Rao <vivekrao4@yahoo.com> 
+ !
+ module str_mod
+   character(3) :: mz(2) = (/"fgh","ijk"/)
+ contains
+   function ccopy(yy) result(xy)
+     character (len=*), intent(in) :: yy(:)
+     character (len=5) :: xy(size(yy))
+     xy = yy
+   end function ccopy
+ end module str_mod
+ !
+ program xx
+   use str_mod, only: ccopy, mz
+   implicit none
+   character(2) :: z = "zz"
+   character(3) :: zz(2) = (/"abc","cde"/)
+   character(2) :: ans(2)
+   integer :: i = 2, j = 3
+   if (any(ccopy("_&_"//(/"A","B"/)//"?") .ne. (/"_&_A?","_&_B?"/))) call abort ()
+   if (any(ccopy(z//zz) .ne. (/"zzabc","zzcde"/))) call abort ()
+   if (any(ccopy(z//zz(:)(1:2)) .ne. (/"zzab ","zzcd "/))) call abort ()
+   if (any(ccopy(z//mz(:)(2:3)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+ 
+ ! This was another bug, uncovered when the PR was fixed.
+   if (any(ccopy(z//mz(:)(i:j)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+ end program xx
+ ! { dg-final { cleanup-modules "str_mod" } }
Index: gcc/testsuite/gfortran.dg/char_assign_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_assign_1.f90	(revision 127610)
--- gcc/testsuite/gfortran.dg/char_assign_1.f90	(working copy)
*************** character(len=2), dimension(5) :: p
*** 11,17 ****
  character(len=3), dimension(5) :: q
  
  y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" }
! p(1) = y(1)%c(3:)
  if (p(1).ne."cd") call abort()
  
  p(1) = y(1)%c  ! { dg-warning "in assignment \\(2/5\\)" }
--- 11,17 ----
  character(len=3), dimension(5) :: q
  
  y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" }
! p(1) = y(1)%c(3:) ! { dg-warning "in assignment \\(2/3\\)" }
  if (p(1).ne."cd") call abort()
  
  p(1) = y(1)%c  ! { dg-warning "in assignment \\(2/5\\)" }
Index: gcc/testsuite/gfortran.dg/char_length_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_length_8.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/char_length_8.f90	(revision 0)
***************
*** 0 ****
--- 1,69 ----
+ ! { dg-do run }
+ ! Test the fix for PR31197 and PR31258 in which the substrings below
+ ! would cause ICEs because the character lengths were never resolved.
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk> 
+ !            and Thomas Koenig <tkoenig@gcc.gnu.org>
+ !
+   CHARACTER(LEN=3), DIMENSION(10) :: Z
+   CHARACTER(LEN=3), DIMENSION(3,3) :: W
+   integer :: ctr = 0
+   call test_reshape
+   call test_eoshift
+   call test_cshift
+   call test_spread
+   call test_transpose
+   call test_pack
+   call test_unpack
+   call test_pr31197
+   if (ctr .ne. 8) call abort
+ contains
+   subroutine test_reshape 
+     Z(:)="123"
+     if (any (RESHAPE(Z(:)(2:2),(/5,2/)) .ne. "2")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_eoshift 
+     CHARACTER(LEN=1), DIMENSION(10) :: chk
+     chk(1:8) = "5"
+     chk(9:10) = " "
+     Z(:)="456"
+     if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) call abort 
+     ctr = ctr + 1
+   END subroutine
+   subroutine test_cshift 
+     Z(:)="901"
+     if (any (CSHIFT(Z(:)(2:2),2) .ne. "0")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_spread 
+     Z(:)="789"
+     if (any (SPREAD(Z(:)(2:2),dim=1,ncopies=2) .ne. "8")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_transpose 
+     W(:, :)="abc"
+     if (any (TRANSPOSE(W(:,:)(1:2)) .ne. "ab")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_pack 
+     W(:, :)="def"
+     if (any (pack(W(:,:)(2:3),mask=.true.) .ne. "ef")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_unpack 
+     logical, dimension(5,2) :: mask
+     Z(:)="hij"
+     mask = .true.
+     if (any (unpack(Z(:)(2:2),mask,' ') .ne. "i")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_pr31197
+     TYPE data
+       CHARACTER(LEN=3) :: A = "xyz"
+     END TYPE
+     TYPE(data), DIMENSION(10), TARGET :: T
+     if (any (TRANSPOSE(RESHAPE(T(:)%A(2:2),(/5,2/))) .ne. "y")) call abort 
+     ctr = ctr + 1
+   end subroutine
+ END

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Paul Thomas]

I had quite forgotten:  This patch also fixes PR32156 - the extraneous 
kludge that is the subject of this PR can be removed.

Cheers

Paul

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[François-Xavier Coudert]

> This patch also fixes PR32156 - the extraneous
> kludge that is the subject of this PR can be removed.

PR32156 was fixed on 2007-05-31, are you sure you got the right PR number?

I'm onto reviewing your patch...

FX

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Tobias Schlüter]

Hi Paul,

I have a few minor observations, apart from which the patch looks ok. 
Since FX is giving it a through review while I've only scanned through 
the patch, and since it's difficult stuff please wait for his comments 
before proceeding.

Paul Thomas wrote:
> *************** gfc_conv_function_call (gfc_se * se, gfc
> *** 2279,2286 ****
>   		  && fsym->as->type != AS_ASSUMED_SHAPE;
>   	      f = f || !sym->attr.always_explicit;
>   
> ! 	      if (e->expr_type == EXPR_VARIABLE
> ! 		    && is_aliased_array (e))
>   		/* The actual argument is a component reference to an
>   		   array of derived types.  In this case, the argument
>   		   is converted to a temporary, which is passed and then
> --- 2255,2261 ----
>   		  && fsym->as->type != AS_ASSUMED_SHAPE;
>   	      f = f || !sym->attr.always_explicit;
>   
> ! 	      if (e->expr_type == EXPR_VARIABLE && is_aliased_array (e))
>   		/* The actual argument is a component reference to an
>   		   array of derived types.  In this case, the argument
>   		   is converted to a temporary, which is passed and then

This hunk is unrelated and not mentioned in the ChangeLog.

> Index: gcc/fortran/resolve.c
> ===================================================================
> *** gcc/fortran/resolve.c	(revision 127610)
> --- gcc/fortran/resolve.c	(working copy)
> *************** resolve_substring (gfc_ref *ref)
> *** 3531,3536 ****
> --- 3531,3598 ----
>   }
>   
>   
> + /* This function supplies missing substring charlens.  */
> + 
> + void
> + gfc_resolve_substring_charlen (gfc_expr *e)
> + {
> +   gfc_ref *char_ref = e->ref;
> +   gfc_expr *start, *end;
> + 
> +   for (; char_ref; char_ref = char_ref->next)
> +     if (char_ref->type == REF_SUBSTRING)
> +       break;
> + 
> +   if (!char_ref)
> +     return;

Stylistically, I don't like the initialization of char_ref outside of 
the for header since it's part of the loop logic.  Further, it probably 
makes sense to assert that the reference is indeed the last in the chain.

> *************** gfc_resolve_expr (gfc_expr *e)
> *** 3933,3938 ****
> --- 4032,4041 ----
>   	  if (t == SUCCESS)
>   	    expression_rank (e);
>   	}
> + 
> +       if (e->ts.type && e->ref && e->ref->type != REF_SUBSTRING)
> + 	gfc_resolve_substring_charlen (e);
> + 
>         break;
>   
>       case EXPR_SUBSTRING:

I'm fairly sure that you want to compare "e->ts.type" with some enum 
value, such as BT_CHARACTER.

Thanks,
- Tobi

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Paul Thomas]

Tobias,
>
>
> This looks much clearer to me.  But if you're short on time, I don't 
> think it's worth changing.
>
Both changes were made and the whole lot was committed last night.

Thanks

Paul

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Tobias Schlüter]

Tobias Burnus wrote:
> Of Tobias Schlüter's comments the following was not addressed:
> 
> +   for (; char_ref; char_ref = char_ref->next)
> +     if (char_ref->type == REF_SUBSTRING)
> +       break;
> 
> He wrote: "Further, it probably makes sense to assert that the reference
> is indeed the last in the chain. "
> 
> Paul's reply was: "(ii) I will change the initialization of the loop and
> assert that the REF_SUBSTRING is the last in the chain - I actually
> removed this assert because it seems to be caught further upstream.
> However, it canot do any harm"
> 
> I think it is ok like thus, but I would also not oppose if an assert
> will be added.

I don't this particular check is worth much.  As far as the function as 
a whole I think the Right Thing to do is:

{ ...
   if (!e->ref)
     return;

   for (char_ref = e->ref; char_ref->next; char_ref = char_ref->next)
     ;

   gcc_assert (char_ref->type == REF_SUBSTRING);
...

This looks much clearer to me.  But if you're short on time, I don't 
think it's worth changing.

Cheers,
- Tobi

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Paul Thomas]

Tobias,
>
> I think it is ok like thus, but I would also not oppose if an assert
> will be added.
>
>   
Thanks - I forgot that one.

I will commit with it just as soon as I can.

Paul

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Tobias Burnus]

Paul Thomas wrote:
> It should be noted that, although PR32703 is fixed, the code that is
> generated is not correct.  Try:
>
> program array_char
> implicit none
> character (len=2) :: x, y
> x = "a "
> y = "cd"
> print*,[trim(x),trim(y)]
> end program array_char

NAG f95 prints for that program (at run time):
   Unequal character lengths (2 and 1) in array constructor
and g95:
  Fortran runtime error: Inconsistent string size in array constructor
ifort, sunf95 and gfortran accept it and print
 acd
openf95 also accepts it but prints
 ac
(if one changes the program to x="ab"; y="c " then ifort/sunf95/gfortran
print "ac" and openf95 prints "abc")

Thus I don't see anything which goes wrong. One could consider to add a
check for this with -fbounds-check, but I think the current output is ok
and sensible (for this input). Or what was the expected output?


> Regtested on Cygwin_NT/amd64 and declared cp2k proof by Tobias - OK
> for trunk?
OK. Though I don't know whether you still want to wait for the comments
of others, e.g., of FX.


Of Tobias Schlüter's comments the following was not addressed:

+   for (; char_ref; char_ref = char_ref->next)
+     if (char_ref->type == REF_SUBSTRING)
+       break;

He wrote: "Further, it probably makes sense to assert that the reference
is indeed the last in the chain. "

Paul's reply was: "(ii) I will change the initialization of the loop and
assert that the REF_SUBSTRING is the last in the chain - I actually
removed this assert because it seems to be caught further upstream.
However, it canot do any harm"

I think it is ok like thus, but I would also not oppose if an assert
will be added.

Tobias

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Paul Thomas]

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

Dear All,

Thank you for all the help on this one.  I attach an updated/corrected 
patch.

It should be noted that, although PR32703 is fixed, the code that is 
generated is not correct.  Try:

program array_char
implicit none
character (len=2) :: x, y
x = "a "
y = "cd"
print*,[trim(x),trim(y)]
end program array_char

This is so different that I propose to close out PR32703, when the patch 
is committed, and to submit a new PR for this bug.

I added a testcase for the fix of the cp2k regression.

Regtested on Cygwin_NT/amd64 and declared cp2k proof by Tobias - OK for 
trunk?

Paul

2007-08-30  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/31879
    PR fortran/31197
    PR fortran/31258
    PR fortran/32703
    * gfortran.h : Add prototype for gfc_resolve_substring_charlen.
    * resolve.c (gfc_resolve_substring_charlen): New function.
    (resolve_ref): Call gfc_resolve_substring_charlen.
    (gfc_resolve_character_operator): New function.
    (gfc_resolve_expr): Call the new functions in cases where the
    character length is missing.
    * iresolve.c (cshift, eoshift, merge, pack, reshape, spread,
    transpose, unpack): Call gfc_resolve_substring_charlen for
    source expressions that are character and have a reference.
    * trans.h (gfc_trans_init_string_length) Change name to
    gfc_conv_string_length; modify references in trans-expr.c,
    trans-array.c and trans-decl.c.
    * trans-expr.c (gfc_trans_string_length): Handle case of no
    backend_decl.
    (gfc_conv_aliased_arg): Remove code for treating substrings
    and replace with call to gfc_trans_string_length.
    * trans-array.c (gfc_conv_expr_descriptor): Remove code for
    treating strings and call gfc_trans_string_length instead.

2007-08-30  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/31879
    * gfortran.dg/char_length_7.f90: New test.
    * gfortran.dg/char_length_9.f90: New test.
    * gfortran.dg/char_assign_1.f90: Add extra warning.

    PR fortran/31197
    PR fortran/31258
    * gfortran.dg/char_length_8.f90: New test.


[-- Attachment #2: submit_plus.diff --]
[-- Type: text/x-patch, Size: 26546 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 127610)
--- gcc/fortran/trans-array.c	(working copy)
*************** get_array_ctor_all_strlen (stmtblock_t *
*** 1381,1387 ****
    if (*len && INTEGER_CST_P (*len))
      return;
  
!   if (!e->ref && e->ts.cl->length
  	&& e->ts.cl->length->expr_type == EXPR_CONSTANT)
      {
        /* This is easy.  */
--- 1381,1387 ----
    if (*len && INTEGER_CST_P (*len))
      return;
  
!   if (!e->ref && e->ts.cl && e->ts.cl->length
  	&& e->ts.cl->length->expr_type == EXPR_CONSTANT)
      {
        /* This is easy.  */
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1645,1661 ****
        if (!ss->string_length)
  	gfc_todo_error ("complex character array constructors");
  
-       /* It is surprising but still possible to wind up with expressions that
- 	 lack a character length.
- 	 TODO Find the offending part of the front end and cure this properly.
- 	 Concatenation involving arrays is the main culprit.  */
-       if (!ss->expr->ts.cl)
- 	{
- 	  ss->expr->ts.cl = gfc_get_charlen ();
- 	  ss->expr->ts.cl->next = gfc_current_ns->cl_list;
- 	  gfc_current_ns->cl_list = ss->expr->ts.cl->next;
- 	}
- 
        ss->expr->ts.cl->backend_decl = ss->string_length;
  
        type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
--- 1645,1650 ----
*************** gfc_trans_auto_array_allocation (tree de
*** 3927,3933 ****
    if (sym->ts.type == BT_CHARACTER
        && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_trans_init_string_length (sym->ts.cl, &block);
  
        gfc_trans_vla_type_sizes (sym, &block);
  
--- 3916,3922 ----
    if (sym->ts.type == BT_CHARACTER
        && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_conv_string_length (sym->ts.cl, &block);
  
        gfc_trans_vla_type_sizes (sym, &block);
  
*************** gfc_trans_auto_array_allocation (tree de
*** 3951,3957 ****
  
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
!     gfc_trans_init_string_length (sym->ts.cl, &block);
  
    size = gfc_trans_array_bounds (type, sym, &offset, &block);
  
--- 3940,3946 ----
  
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
!     gfc_conv_string_length (sym->ts.cl, &block);
  
    size = gfc_trans_array_bounds (type, sym, &offset, &block);
  
*************** gfc_trans_g77_array (gfc_symbol * sym, t
*** 4017,4023 ****
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_trans_init_string_length (sym->ts.cl, &block);
  
    /* Evaluate the bounds of the array.  */
    gfc_trans_array_bounds (type, sym, &offset, &block);
--- 4006,4012 ----
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_conv_string_length (sym->ts.cl, &block);
  
    /* Evaluate the bounds of the array.  */
    gfc_trans_array_bounds (type, sym, &offset, &block);
*************** gfc_trans_dummy_array_bias (gfc_symbol *
*** 4109,4115 ****
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_trans_init_string_length (sym->ts.cl, &block);
  
    checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
  
--- 4098,4104 ----
  
    if (sym->ts.type == BT_CHARACTER
        && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
!     gfc_conv_string_length (sym->ts.cl, &block);
  
    checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
  
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4548,4610 ****
        loop.temp_ss = gfc_get_ss ();
        loop.temp_ss->type = GFC_SS_TEMP;
        loop.temp_ss->next = gfc_ss_terminator;
        if (expr->ts.type == BT_CHARACTER)
! 	{
! 	  if (expr->ts.cl == NULL)
! 	    {
! 	      /* This had better be a substring reference!  */
! 	      gfc_ref *char_ref = expr->ref;
! 	      for (; char_ref; char_ref = char_ref->next)
! 		if (char_ref->type == REF_SUBSTRING)
! 		  {
! 		    mpz_t char_len;
! 		    expr->ts.cl = gfc_get_charlen ();
! 		    expr->ts.cl->next = char_ref->u.ss.length->next;
! 		    char_ref->u.ss.length->next = expr->ts.cl;
! 
! 		    mpz_init_set_ui (char_len, 1);
! 		    mpz_add (char_len, char_len,
! 			     char_ref->u.ss.end->value.integer);
! 		    mpz_sub (char_len, char_len,
! 			     char_ref->u.ss.start->value.integer);
! 		    expr->ts.cl->backend_decl
! 			= gfc_conv_mpz_to_tree (char_len,
! 					gfc_default_character_kind);
! 		    /* Cast is necessary for *-charlen refs.  */
! 		    expr->ts.cl->backend_decl
! 			= convert (gfc_charlen_type_node,
! 				   expr->ts.cl->backend_decl);
! 		    mpz_clear (char_len);
! 		      break;
! 		  }
! 	      gcc_assert (char_ref != NULL);
! 	      loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
! 	      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! 	    }
! 	  else if (expr->ts.cl->length
! 		     && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
! 	    {
! 	      gfc_conv_const_charlen (expr->ts.cl);
! 	      loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
! 	      loop.temp_ss->string_length
! 		= TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
! 	    }
! 	  else
! 	    {
! 	      loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
! 	      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! 	    }
! 	  se->string_length = loop.temp_ss->string_length;
! 	}
        else
! 	{
! 	  loop.temp_ss->data.temp.type
! 	    = gfc_typenode_for_spec (&expr->ts);
! 	  loop.temp_ss->string_length = NULL;
! 	}
        loop.temp_ss->data.temp.dimen = loop.dimen;
        gfc_add_ss_to_loop (&loop, loop.temp_ss);
      }
--- 4537,4554 ----
        loop.temp_ss = gfc_get_ss ();
        loop.temp_ss->type = GFC_SS_TEMP;
        loop.temp_ss->next = gfc_ss_terminator;
+ 
+       if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+ 	gfc_conv_string_length (expr->ts.cl, &se->pre);
+ 
+       loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+ 
        if (expr->ts.type == BT_CHARACTER)
! 	loop.temp_ss->string_length = expr->ts.cl->backend_decl;
        else
! 	loop.temp_ss->string_length = NULL;
! 
!       se->string_length = loop.temp_ss->string_length;
        loop.temp_ss->data.temp.dimen = loop.dimen;
        gfc_add_ss_to_loop (&loop, loop.temp_ss);
      }
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 5337,5343 ****
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_trans_init_string_length (sym->ts.cl, &fnblock);
        gfc_trans_vla_type_sizes (sym, &fnblock);
      }
  
--- 5281,5287 ----
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      {
!       gfc_conv_string_length (sym->ts.cl, &fnblock);
        gfc_trans_vla_type_sizes (sym, &fnblock);
      }
  
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 127610)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 220,229 ****
     value.  */
  
  void
! gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
  {
    gfc_se se;
-   tree tmp;
  
    gfc_init_se (&se, NULL);
    gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
--- 220,228 ----
     value.  */
  
  void
! gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
  {
    gfc_se se;
  
    gfc_init_se (&se, NULL);
    gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
*************** gfc_trans_init_string_length (gfc_charle
*** 231,238 ****
  			 build_int_cst (gfc_charlen_type_node, 0));
    gfc_add_block_to_block (pblock, &se.pre);
  
!   tmp = cl->backend_decl;
!   gfc_add_modify_expr (pblock, tmp, se.expr);
  }
  
  
--- 230,239 ----
  			 build_int_cst (gfc_charlen_type_node, 0));
    gfc_add_block_to_block (pblock, &se.pre);
  
!   if (cl->backend_decl)
!     gfc_add_modify_expr (pblock, cl->backend_decl, se.expr);
!   else
!     cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
  }
  
  
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1823,1828 ****
--- 1824,1832 ----
    gfc_conv_ss_startstride (&loop);
  
    /* Build an ss for the temporary.  */
+   if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+     gfc_conv_string_length (expr->ts.cl, &parmse->pre);
+ 
    base_type = gfc_typenode_for_spec (&expr->ts);
    if (GFC_ARRAY_TYPE_P (base_type)
  		|| GFC_DESCRIPTOR_TYPE_P (base_type))
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1833,1871 ****
    loop.temp_ss->data.temp.type = base_type;
  
    if (expr->ts.type == BT_CHARACTER)
!     {
!       gfc_ref *char_ref = expr->ref;
! 
!       for (; char_ref; char_ref = char_ref->next)
! 	if (char_ref->type == REF_SUBSTRING)
! 	  {
! 	    gfc_se tmp_se;
! 
! 	    expr->ts.cl = gfc_get_charlen ();
! 	    expr->ts.cl->next = char_ref->u.ss.length->next;
! 	    char_ref->u.ss.length->next = expr->ts.cl;
! 
! 	    gfc_init_se (&tmp_se, NULL);
! 	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
! 				gfc_array_index_type);
! 	    tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
! 			       tmp_se.expr, gfc_index_one_node);
! 	    tmp = gfc_evaluate_now (tmp, &parmse->pre);
! 	    gfc_init_se (&tmp_se, NULL);
! 	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
! 				gfc_array_index_type);
! 	    tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
! 			       tmp, tmp_se.expr);
! 	    tmp = fold_convert (gfc_charlen_type_node, tmp);
! 	    expr->ts.cl->backend_decl = tmp;
! 
! 	    break;
! 	  }
!       loop.temp_ss->data.temp.type
! 		= gfc_typenode_for_spec (&expr->ts);
!       loop.temp_ss->string_length = expr->ts.cl->backend_decl;
!     }
  
    loop.temp_ss->data.temp.dimen = loop.dimen;
    loop.temp_ss->next = gfc_ss_terminator;
  
--- 1837,1847 ----
    loop.temp_ss->data.temp.type = base_type;
  
    if (expr->ts.type == BT_CHARACTER)
!     loop.temp_ss->string_length = expr->ts.cl->backend_decl;
!   else
!     loop.temp_ss->string_length = NULL;
  
+   parmse->string_length = loop.temp_ss->string_length;
    loop.temp_ss->data.temp.dimen = loop.dimen;
    loop.temp_ss->next = gfc_ss_terminator;
  
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 127610)
--- gcc/fortran/gfortran.h	(working copy)
*************** try gfc_resolve_iterator (gfc_iterator *
*** 2268,2273 ****
--- 2268,2274 ----
  try gfc_resolve_index (gfc_expr *, int);
  try gfc_resolve_dim_arg (gfc_expr *);
  int gfc_is_formal_arg (void);
+ void gfc_resolve_substring_charlen (gfc_expr *);
  match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
  
  
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 127610)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_conv_string_tmp (gfc_se *, tree
*** 340,346 ****
  /* Get the string length variable belonging to an expression.  */
  tree gfc_get_expr_charlen (gfc_expr *);
  /* Initialize a string length variable.  */
! void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
  /* Ensure type sizes can be gimplified.  */
  void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
  
--- 340,346 ----
  /* Get the string length variable belonging to an expression.  */
  tree gfc_get_expr_charlen (gfc_expr *);
  /* Initialize a string length variable.  */
! void gfc_conv_string_length (gfc_charlen *, stmtblock_t *);
  /* Ensure type sizes can be gimplified.  */
  void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
  
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 127610)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_substring (gfc_ref *ref)
*** 3531,3536 ****
--- 3531,3598 ----
  }
  
  
+ /* This function supplies missing substring charlens.  */
+ 
+ void
+ gfc_resolve_substring_charlen (gfc_expr *e)
+ {
+   gfc_ref *char_ref = e->ref;
+   gfc_expr *start, *end;
+ 
+   for (; char_ref; char_ref = char_ref->next)
+     if (char_ref->type == REF_SUBSTRING)
+       break;
+ 
+   if (!char_ref)
+     return;
+ 
+   if (e->ts.cl)
+     {
+       if (e->ts.cl->length)
+ 	gfc_free_expr (e->ts.cl->length);
+       else if (e->expr_type == EXPR_VARIABLE
+ 		 && e->symtree->n.sym->attr.dummy)
+ 	return;
+     }
+ 
+   e->ts.type = BT_CHARACTER;
+   e->ts.kind = gfc_default_character_kind;
+ 
+   if (!e->ts.cl)
+     {
+       e->ts.cl = gfc_get_charlen ();
+       e->ts.cl->next = gfc_current_ns->cl_list;
+       gfc_current_ns->cl_list = e->ts.cl;
+     }
+ 
+   if (char_ref->u.ss.start)
+     start = gfc_copy_expr (char_ref->u.ss.start);
+   else
+     start = gfc_int_expr (1);
+ 
+   if (char_ref->u.ss.end)
+     end = gfc_copy_expr (char_ref->u.ss.end);
+   else if (e->expr_type == EXPR_VARIABLE)
+     end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
+   else
+     end = NULL;
+ 
+   if (!start || !end)
+     return;
+ 
+   /* Length = (end - start +1).  */
+   e->ts.cl->length = gfc_subtract (end, start);
+   e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
+ 
+   e->ts.cl->length->ts.type = BT_INTEGER;
+   e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+ 
+   /* Make sure that the length is simplified.  */
+   gfc_simplify_expr (e->ts.cl->length, 1);
+   gfc_resolve_expr (e->ts.cl->length);
+ }
+ 
+ 
  /* Resolve subtype references.  */
  
  static try
*************** check_host_association (gfc_expr *e)
*** 3904,3909 ****
--- 3966,4043 ----
  }
  
  
+ static void
+ gfc_resolve_character_operator (gfc_expr *e)
+ {
+   gfc_expr *op1 = e->value.op.op1;
+   gfc_expr *op2 = e->value.op.op2;
+   gfc_expr *e1 = NULL;
+   gfc_expr *e2 = NULL;
+ 
+   gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
+ 
+   if (op1->ts.cl && op1->ts.cl->length)
+     e1 = gfc_copy_expr (op1->ts.cl->length);
+   else if (op1->expr_type == EXPR_CONSTANT)
+     e1 = gfc_int_expr (op1->value.character.length);
+ 
+   if (op2->ts.cl && op2->ts.cl->length)
+     e2 = gfc_copy_expr (op2->ts.cl->length);
+   else if (op2->expr_type == EXPR_CONSTANT)
+     e2 = gfc_int_expr (op2->value.character.length);
+ 
+   e->ts.cl = gfc_get_charlen ();
+   e->ts.cl->next = gfc_current_ns->cl_list;
+   gfc_current_ns->cl_list = e->ts.cl;
+ 
+   if (!e1 || !e2)
+     return;
+ 
+   e->ts.cl->length = gfc_add (e1, e2);
+   e->ts.cl->length->ts.type = BT_INTEGER;
+   e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+   gfc_simplify_expr (e->ts.cl->length, 0);
+   gfc_resolve_expr (e->ts.cl->length);
+ 
+   return;
+ }
+ 
+ 
+ /*  Ensure that an character expression has a charlen and, if possible, a
+     length expression.  */
+ 
+ static void
+ fixup_charlen (gfc_expr *e)
+ {
+   /* The cases fall through so that changes in expression type and the need
+      for multiple fixes are picked up.  In all circumstances, a charlen should
+      be available for the middle end to hang a backend_decl on.  */
+   switch (e->expr_type)
+     {
+     case EXPR_OP:
+       gfc_resolve_character_operator (e);
+ 
+     case EXPR_ARRAY:
+       if (e->expr_type == EXPR_ARRAY)
+ 	gfc_resolve_character_array_constructor (e);
+ 
+     case EXPR_SUBSTRING:
+       if (!e->ts.cl && e->ref)
+ 	gfc_resolve_substring_charlen (e);
+ 
+     default:
+       if (!e->ts.cl)
+ 	{
+ 	  e->ts.cl = gfc_get_charlen ();
+ 	  e->ts.cl->next = gfc_current_ns->cl_list;
+ 	  gfc_current_ns->cl_list = e->ts.cl;
+ 	}
+ 
+       break;
+     }
+ }
+ 
+ 
  /* Resolve an expression.  That is, make sure that types of operands agree
     with their operators, intrinsic operators are converted to function calls
     for overloaded types and unresolved function references are resolved.  */
*************** gfc_resolve_expr (gfc_expr *e)
*** 3933,3938 ****
--- 4067,4077 ----
  	  if (t == SUCCESS)
  	    expression_rank (e);
  	}
+ 
+       if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
+ 	    && e->ref->type != REF_SUBSTRING)
+ 	gfc_resolve_substring_charlen (e);
+ 
        break;
  
      case EXPR_SUBSTRING:
*************** gfc_resolve_expr (gfc_expr *e)
*** 3981,3986 ****
--- 4120,4128 ----
        gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
      }
  
+   if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
+     fixup_charlen (e);
+ 
    return t;
  }
  
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c	(revision 127610)
--- gcc/fortran/iresolve.c	(working copy)
*************** gfc_resolve_cshift (gfc_expr *f, gfc_exp
*** 548,553 ****
--- 548,556 ----
  {
    int n;
  
+   if (array->ts.type == BT_CHARACTER && array->ref)
+     gfc_resolve_substring_charlen (array);
+ 
    f->ts = array->ts;
    f->rank = array->rank;
    f->shape = gfc_copy_shape (array->shape, array->rank);
*************** gfc_resolve_eoshift (gfc_expr *f, gfc_ex
*** 668,673 ****
--- 671,679 ----
  {
    int n;
  
+   if (array->ts.type == BT_CHARACTER && array->ref)
+     gfc_resolve_substring_charlen (array);
+ 
    f->ts = array->ts;
    f->rank = array->rank;
    f->shape = gfc_copy_shape (array->shape, array->rank);
*************** gfc_resolve_merge (gfc_expr *f, gfc_expr
*** 1378,1383 ****
--- 1384,1395 ----
  		   gfc_expr *fsource ATTRIBUTE_UNUSED,
  		   gfc_expr *mask ATTRIBUTE_UNUSED)
  {
+   if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+     gfc_resolve_substring_charlen (tsource);
+ 
+   if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+     gfc_resolve_substring_charlen (fsource);
+ 
    if (tsource->ts.type == BT_CHARACTER)
      check_charlen_present (tsource);
  
*************** void
*** 1586,1591 ****
--- 1598,1606 ----
  gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
  		  gfc_expr *vector ATTRIBUTE_UNUSED)
  {
+   if (array->ts.type == BT_CHARACTER && array->ref)
+     gfc_resolve_substring_charlen (array);
+ 
    f->ts = array->ts;
    f->rank = 1;
  
*************** gfc_resolve_reshape (gfc_expr *f, gfc_ex
*** 1689,1694 ****
--- 1704,1712 ----
    int kind;
    int i;
  
+   if (source->ts.type == BT_CHARACTER && source->ref)
+     gfc_resolve_substring_charlen (source);
+ 
    f->ts = source->ts;
  
    gfc_array_size (shape, &rank);
*************** void
*** 1980,1985 ****
--- 1998,2006 ----
  gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
  		    gfc_expr *ncopies)
  {
+   if (source->ts.type == BT_CHARACTER && source->ref)
+     gfc_resolve_substring_charlen (source);
+ 
    if (source->ts.type == BT_CHARACTER)
      check_charlen_present (source);
  
*************** gfc_resolve_transfer (gfc_expr *f, gfc_e
*** 2254,2259 ****
--- 2275,2284 ----
  void
  gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
  {
+ 
+   if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+     gfc_resolve_substring_charlen (matrix);
+ 
    f->ts = matrix->ts;
    f->rank = 2;
    if (matrix->shape)
*************** void
*** 2380,2385 ****
--- 2405,2413 ----
  gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
  		    gfc_expr *field ATTRIBUTE_UNUSED)
  {
+   if (vector->ts.type == BT_CHARACTER && vector->ref)
+     gfc_resolve_substring_charlen (vector);
+ 
    f->ts = vector->ts;
    f->rank = mask->rank;
    resolve_mask_arg (mask);
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 127610)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_trans_dummy_character (gfc_symbol *s
*** 2420,2426 ****
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_trans_init_string_length (cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
--- 2420,2426 ----
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_conv_string_length (cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
*************** gfc_trans_auto_character_variable (gfc_s
*** 2444,2450 ****
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_trans_init_string_length (sym->ts.cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
--- 2444,2450 ----
    gfc_start_block (&body);
  
    /* Evaluate the string length expression.  */
!   gfc_conv_string_length (sym->ts.cl, &body);
  
    gfc_trans_vla_type_sizes (sym, &body);
  
Index: gcc/testsuite/gfortran.dg/char_length_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_length_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/char_length_7.f90	(revision 0)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ ! Test the fix for PR31879 in which the concatenation operators below
+ ! would cause ICEs because the character lengths were never resolved.
+ !
+ ! Contributed by Vivek Rao <vivekrao4@yahoo.com> 
+ !
+ module str_mod
+   character(3) :: mz(2) = (/"fgh","ijk"/)
+ contains
+   function ccopy(yy) result(xy)
+     character (len=*), intent(in) :: yy(:)
+     character (len=5) :: xy(size(yy))
+     xy = yy
+   end function ccopy
+ end module str_mod
+ !
+ program xx
+   use str_mod, only: ccopy, mz
+   implicit none
+   character(2) :: z = "zz"
+   character(3) :: zz(2) = (/"abc","cde"/)
+   character(2) :: ans(2)
+   integer :: i = 2, j = 3
+   if (any(ccopy("_&_"//(/"A","B"/)//"?") .ne. (/"_&_A?","_&_B?"/))) call abort ()
+   if (any(ccopy(z//zz) .ne. (/"zzabc","zzcde"/))) call abort ()
+   if (any(ccopy(z//zz(:)(1:2)) .ne. (/"zzab ","zzcd "/))) call abort ()
+   if (any(ccopy(z//mz(:)(2:3)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+ 
+ ! This was another bug, uncovered when the PR was fixed.
+   if (any(ccopy(z//mz(:)(i:j)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+ end program xx
+ ! { dg-final { cleanup-modules "str_mod" } }
Index: gcc/testsuite/gfortran.dg/char_assign_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_assign_1.f90	(revision 127610)
--- gcc/testsuite/gfortran.dg/char_assign_1.f90	(working copy)
*************** character(len=2), dimension(5) :: p
*** 11,17 ****
  character(len=3), dimension(5) :: q
  
  y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" }
! p(1) = y(1)%c(3:)
  if (p(1).ne."cd") call abort()
  
  p(1) = y(1)%c  ! { dg-warning "in assignment \\(2/5\\)" }
--- 11,17 ----
  character(len=3), dimension(5) :: q
  
  y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" }
! p(1) = y(1)%c(3:) ! { dg-warning "in assignment \\(2/3\\)" }
  if (p(1).ne."cd") call abort()
  
  p(1) = y(1)%c  ! { dg-warning "in assignment \\(2/5\\)" }
Index: gcc/testsuite/gfortran.dg/char_length_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_length_8.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/char_length_8.f90	(revision 0)
***************
*** 0 ****
--- 1,69 ----
+ ! { dg-do run }
+ ! Test the fix for PR31197 and PR31258 in which the substrings below
+ ! would cause ICEs because the character lengths were never resolved.
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk> 
+ !            and Thomas Koenig <tkoenig@gcc.gnu.org>
+ !
+   CHARACTER(LEN=3), DIMENSION(10) :: Z
+   CHARACTER(LEN=3), DIMENSION(3,3) :: W
+   integer :: ctr = 0
+   call test_reshape
+   call test_eoshift
+   call test_cshift
+   call test_spread
+   call test_transpose
+   call test_pack
+   call test_unpack
+   call test_pr31197
+   if (ctr .ne. 8) call abort
+ contains
+   subroutine test_reshape 
+     Z(:)="123"
+     if (any (RESHAPE(Z(:)(2:2),(/5,2/)) .ne. "2")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_eoshift 
+     CHARACTER(LEN=1), DIMENSION(10) :: chk
+     chk(1:8) = "5"
+     chk(9:10) = " "
+     Z(:)="456"
+     if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) call abort 
+     ctr = ctr + 1
+   END subroutine
+   subroutine test_cshift 
+     Z(:)="901"
+     if (any (CSHIFT(Z(:)(2:2),2) .ne. "0")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_spread 
+     Z(:)="789"
+     if (any (SPREAD(Z(:)(2:2),dim=1,ncopies=2) .ne. "8")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_transpose 
+     W(:, :)="abc"
+     if (any (TRANSPOSE(W(:,:)(1:2)) .ne. "ab")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_pack 
+     W(:, :)="def"
+     if (any (pack(W(:,:)(2:3),mask=.true.) .ne. "ef")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_unpack 
+     logical, dimension(5,2) :: mask
+     Z(:)="hij"
+     mask = .true.
+     if (any (unpack(Z(:)(2:2),mask,' ') .ne. "i")) call abort 
+     ctr = ctr + 1
+   end subroutine
+   subroutine test_pr31197
+     TYPE data
+       CHARACTER(LEN=3) :: A = "xyz"
+     END TYPE
+     TYPE(data), DIMENSION(10), TARGET :: T
+     if (any (TRANSPOSE(RESHAPE(T(:)%A(2:2),(/5,2/))) .ne. "y")) call abort 
+     ctr = ctr + 1
+   end subroutine
+ END
Index: gcc/testsuite/gfortran.dg/char_length_9.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_length_9.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/char_length_9.f90	(revision 0)
***************
*** 0 ****
--- 1,22 ----
+ ! { dg-do compile }
+ ! Test the fix for a regression caused by the first fix of PR31879.
+ ! Reported by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ MODULE input_val_types
+   IMPLICIT NONE
+   INTEGER, PARAMETER :: default_string_length=80
+   TYPE val_type
+     CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: c_val
+   END TYPE val_type
+ CONTAINS
+   SUBROUTINE val_get (val, c_val)
+     TYPE(val_type), POINTER                  :: val
+     CHARACTER(LEN=*), INTENT(out)            :: c_val
+     INTEGER                                  :: i, l_out
+     i=1
+     c_val((i-1)*default_string_length+1:MIN (l_out, i*default_string_length)) = &
+                val%c_val(i)(1:MIN (80, l_out-(i-1)*default_string_length))
+   END SUBROUTINE val_get
+ END MODULE input_val_types
+ 
+ ! { dg-final { cleanup-modules "input_val_types" } }

Re: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems

[Paul Richard Thomas]

FX and Tobi,

Many thanks for your respective comments:

(i) The hunk in gfc_conv_function_call is indeed unrelated but is only
a format change;
(ii) I will change the initialization of the loop and assert that the
REF_SUBSTRING is the last in the chain - I actually removed this
assert because it seems to be caught further upstream.  However, it
canot do any harm;
(iii) The e->ts.type is an error - it is missing == BT_CHARACTER &&
!e->ts.cl.  This came about because of bit-rot between the original
writing of the patch and a couple of days ago.  I had to apply quite a
lot of the pacth by hand.  This caused a regression in CP2K that
Tobias Burnus picked up.
(iv) As for PR32156, looked who fixed it.....  Right now, I am not
sure which PR that I meant.

Tobias Burnus and I had an exchange on #gfortran and by email, last
night and this morning.  He identified two problems that have been
fixed but need testcases.  I will emit the updated patch tonight.

Many thanks to you all

Paul