[Patch, Fortran] PR fortran/35846: ICE on character array constructor

[Daniel Kraft <d at domob dot eu>]

Hi,

this is a fix for PR fortran/35846 where character array constructor
ICEd in certain situations because gfc_conv_string_length could be
called with a charlength structure whose length was NULL.  The patch
adds logic to handle this special case.  Some details can be found in
the PR in my last comment.

After fixing the ICE, the problem with the global variables pointed out
broke bounds-checking for the tests, which I fixed by saving & restoring
their values.

No regressions on GNU/Linux-x86-32.  Ok for trunk?  Should I backport it
for 4.3 also or do you think it is too complicated?

BTW, my patch should have not much potential for regressions as the new
code is only executed in places where the code would've ICE'd before; at
least I think so...

Cheers,
Daniel

--
Done:     Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
To go:    Hea-Kni-Mon-Pri-Ran-Rog-Tou

2008-09-20  Daniel Kraft  <d@domob.eu>

	PR fortran/35846
	* trans.h (gfc_conv_string_length): New argument `expr'.
	* trans-expr.c (flatten_array_ctors_without_strlen): New method.
	(gfc_conv_string_length): New argument `expr' that is used in a new
	special case handling if cl->length is NULL.
	(gfc_conv_subref_array_arg): Pass expr to gfc_conv_string_length.
	* trans-array.c (gfc_conv_expr_descriptor): Ditto.
	(gfc_trans_auto_array_allocation): Pass NULL as new expr.
	(gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto.
	(gfc_trans_deferred_array): Ditto.
	(gfc_trans_array_constructor): Save and restore old values of globals
	used for bounds checking.
	* trans-decl.c (gfc_trans_dummy_character): Ditto.
	(gfc_trans_auto_character_variable): Ditto.

2008-09-20  Daniel Kraft  <d@domob.eu>

	PR fortran/35846
	* gfortran.dg/nested_array_constructor_1.f90: New test.
	* gfortran.dg/nested_array_constructor_2.f90: New test.
	* gfortran.dg/nested_array_constructor_3.f90: New test.
	* gfortran.dg/nested_array_constructor_4.f90: New test.
	* gfortran.dg/nested_array_constructor_5.f90: New test.

Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 140465)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -1694,6 +1694,13 @@ gfc_trans_array_constructor (gfc_loopinf
   tree type;
   tree loopfrom;
   bool dynamic;
+  bool old_first_len, old_typespec_chararray_ctor;
+  tree old_first_len_val;
+
+  /* Save the old values for nested checking.  */
+  old_first_len = first_len;
+  old_first_len_val = first_len_val;
+  old_typespec_chararray_ctor = typespec_chararray_ctor;
 
   /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
      typespec was given for the array constructor.  */
@@ -1792,7 +1799,7 @@ gfc_trans_array_constructor (gfc_loopinf
 	  if (size && compare_tree_int (size, nelem) == 0)
 	    {
 	      gfc_trans_constant_array_constructor (loop, ss, type);
-	      return;
+	      goto finish;
 	    }
 	}
     }
@@ -1849,6 +1856,12 @@ gfc_trans_array_constructor (gfc_loopinf
       gcc_unreachable ();
     }
 #endif
+
+finish:
+  /* Restore old values of globals.  */
+  first_len = old_first_len;
+  first_len_val = old_first_len_val;
+  typespec_chararray_ctor = old_typespec_chararray_ctor;
 }
 
 
@@ -4080,7 +4093,7 @@ gfc_trans_auto_array_allocation (tree de
   if (sym->ts.type == BT_CHARACTER
       && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
     {
-      gfc_conv_string_length (sym->ts.cl, &block);
+      gfc_conv_string_length (sym->ts.cl, NULL, &block);
 
       gfc_trans_vla_type_sizes (sym, &block);
 
@@ -4104,7 +4117,7 @@ gfc_trans_auto_array_allocation (tree de
 
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.cl->backend_decl))
-    gfc_conv_string_length (sym->ts.cl, &block);
+    gfc_conv_string_length (sym->ts.cl, NULL, &block);
 
   size = gfc_trans_array_bounds (type, sym, &offset, &block);
 
@@ -4170,7 +4183,7 @@ gfc_trans_g77_array (gfc_symbol * sym, t
 
   if (sym->ts.type == BT_CHARACTER
       && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
-    gfc_conv_string_length (sym->ts.cl, &block);
+    gfc_conv_string_length (sym->ts.cl, NULL, &block);
 
   /* Evaluate the bounds of the array.  */
   gfc_trans_array_bounds (type, sym, &offset, &block);
@@ -4262,7 +4275,7 @@ gfc_trans_dummy_array_bias (gfc_symbol *
 
   if (sym->ts.type == BT_CHARACTER
       && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
-    gfc_conv_string_length (sym->ts.cl, &block);
+    gfc_conv_string_length (sym->ts.cl, NULL, &block);
 
   checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
 
@@ -4848,7 +4861,6 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       break;
     }
 
-
   gfc_init_loopinfo (&loop);
 
   /* Associate the SS with the loop.  */
@@ -4872,7 +4884,7 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       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);
+	gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
 
       loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
 
@@ -5672,7 +5684,7 @@ gfc_trans_deferred_array (gfc_symbol * s
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.cl->backend_decl))
     {
-      gfc_conv_string_length (sym->ts.cl, &fnblock);
+      gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
       gfc_trans_vla_type_sizes (sym, &fnblock);
     }
 
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 140465)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -241,17 +241,101 @@ gfc_get_expr_charlen (gfc_expr *e)
   return length;
 }
 
-  
+
+/* For each character array constructor subexpression without a ts.cl->length,
+   replace it by its first element (if there aren't any elements, the length
+   should already be set to zero).  */
+
+static void
+flatten_array_ctors_without_strlen (gfc_expr* e)
+{
+  gfc_actual_arglist* arg;
+  gfc_constructor* c;
+
+  if (!e)
+    return;
+
+  switch (e->expr_type)
+    {
+
+    case EXPR_OP:
+      flatten_array_ctors_without_strlen (e->value.op.op1); 
+      flatten_array_ctors_without_strlen (e->value.op.op2); 
+      break;
+
+    case EXPR_COMPCALL:
+      /* TODO: Implement as with EXPR_FUNCTION when needed.  */
+      gcc_unreachable ();
+
+    case EXPR_FUNCTION:
+      for (arg = e->value.function.actual; arg; arg = arg->next)
+	flatten_array_ctors_without_strlen (arg->expr);
+      break;
+
+    case EXPR_ARRAY:
+
+      /* We've found what we're looking for.  */
+      if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+	{
+	  gfc_expr* new_expr;
+	  gcc_assert (e->value.constructor);
+
+	  new_expr = e->value.constructor->expr;
+	  e->value.constructor->expr = NULL;
+
+	  gfc_replace_expr (e, new_expr);
+	  break;
+	}
+
+      /* Otherwise, fall through to handle constructor elements.  */
+    case EXPR_STRUCTURE:
+      for (c = e->value.constructor; c; c = c->next)
+	flatten_array_ctors_without_strlen (c->expr);
+      break;
+
+    default:
+      break;
+
+    }
+}
+
 
 /* Generate code to initialize a string length variable. Returns the
-   value.  */
+   value.  For array constructors, cl->length might be NULL and in this case,
+   the first element of the constructor is needed.  expr is the original
+   expression so we can access it but can be NULL if this is not needed.  */
 
 void
-gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
+gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
 {
   gfc_se se;
 
   gfc_init_se (&se, NULL);
+
+  /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
+     "flatten" array constructors by taking their first element; all elements
+     should be the same length or a cl->length should be present.  */
+  if (!cl->length)
+    {
+      gfc_expr* expr_flat;
+      gcc_assert (expr);
+
+      expr_flat = gfc_copy_expr (expr);
+      flatten_array_ctors_without_strlen (expr_flat);
+      gfc_resolve_expr (expr_flat);
+
+      gfc_conv_expr (&se, expr_flat);
+      gfc_add_block_to_block (pblock, &se.pre);
+      cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
+
+      gfc_free_expr (expr_flat);
+      return;
+    }
+
+  /* Convert cl->length.  */
+
+  gcc_assert (cl->length);
+
   gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
   se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
 			 build_int_cst (gfc_charlen_type_node, 0));
@@ -2092,7 +2176,7 @@ gfc_conv_subref_array_arg (gfc_se * parm
 
   /* 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);
+    gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
 
   base_type = gfc_typenode_for_spec (&expr->ts);
   if (GFC_ARRAY_TYPE_P (base_type)
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 140465)
+++ gcc/fortran/trans.h	(working copy)
@@ -340,7 +340,7 @@ tree gfc_conv_string_tmp (gfc_se *, tree
 /* 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 *);
+void gfc_conv_string_length (gfc_charlen *, gfc_expr *, stmtblock_t *);
 /* Ensure type sizes can be gimplified.  */
 void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
 
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 140465)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -2583,7 +2583,7 @@ gfc_trans_dummy_character (gfc_symbol *s
   gfc_start_block (&body);
 
   /* Evaluate the string length expression.  */
-  gfc_conv_string_length (cl, &body);
+  gfc_conv_string_length (cl, NULL, &body);
 
   gfc_trans_vla_type_sizes (sym, &body);
 
@@ -2607,7 +2607,7 @@ gfc_trans_auto_character_variable (gfc_s
   gfc_start_block (&body);
 
   /* Evaluate the string length expression.  */
-  gfc_conv_string_length (sym->ts.cl, &body);
+  gfc_conv_string_length (sym->ts.cl, NULL, &body);
 
   gfc_trans_vla_type_sizes (sym, &body);
 
Index: gcc/testsuite/gfortran.dg/nested_array_constructor_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/nested_array_constructor_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/nested_array_constructor_1.f90	(revision 0)
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! This test is run with result-checking and -fbounds-check as
+! nested_array_constructor_2.f90
+
+! PR fortran/35846
+! This used to ICE because the charlength of the trim-expression was
+! NULL.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+character(len=2) :: c(3)
+
+c = 'a'
+c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /)
+
+print *, c
+
+end
Index: gcc/testsuite/gfortran.dg/nested_array_constructor_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/nested_array_constructor_3.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/nested_array_constructor_3.f90	(revision 0)
@@ -0,0 +1,22 @@
+! { dg-do run }
+
+! PR fortran/35846
+! Alternate test that also produced an ICE because of a missing length.
+
+PROGRAM test
+  IMPLICIT NONE
+  CHARACTER(LEN=2) :: x
+
+  x = 'a'
+  CALL sub ( (/ TRIM(x), 'a' /) // 'c')
+END PROGRAM
+
+SUBROUTINE sub(str)
+  IMPLICIT NONE
+  CHARACTER(LEN=*) :: str(2)
+  WRITE (*,*) str
+
+  IF (str(1) /= 'ac' .OR. str(2) /= 'ac') THEN
+    CALL abort ()
+  END IF
+END SUBROUTINE sub
Index: gcc/testsuite/gfortran.dg/nested_array_constructor_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/nested_array_constructor_5.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/nested_array_constructor_5.f90	(revision 0)
@@ -0,0 +1,16 @@
+! { dg-do compile }
+
+! PR fortran/35846
+! This used to ICE because the charlength of the trim-expression was
+! NULL, but it is switched around to test for the right operand of // being
+! not a constant, too.
+
+implicit none
+character(len=2) :: c(2)
+
+c = 'a'
+c = (/ (/ trim(c(1)), 'a' /) // (/ trim(c(1)), 'a' /) /)
+
+print *, c
+
+end
Index: gcc/testsuite/gfortran.dg/nested_array_constructor_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/nested_array_constructor_2.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/nested_array_constructor_2.f90	(revision 0)
@@ -0,0 +1,22 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+
+! PR fortran/35846
+! This used to ICE because the charlength of the trim-expression was
+! NULL.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+character(len=2) :: c(3)
+
+c = 'a'
+c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /)
+
+print *, c
+
+if (c(1) /= 'ac' .or. c(2) /= 'ac' .or. c(3) /= 'cd') then
+  call abort ()
+end if
+
+end
Index: gcc/testsuite/gfortran.dg/nested_array_constructor_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/nested_array_constructor_4.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/nested_array_constructor_4.f90	(revision 0)
@@ -0,0 +1,17 @@
+! { dg-do run }
+
+! PR fortran/35846
+! Alternate test that also produced an ICE because of a missing length.
+
+PROGRAM test
+  IMPLICIT NONE
+  CHARACTER(LEN=2) :: x
+  INTEGER :: length
+
+  x = 'a'
+  length = LEN ( (/ TRIM(x), 'a' /) // 'c')
+
+  IF (length /= 2) THEN
+    CALL abort ()
+  END IF
+END PROGRAM