re PR fortran/35846 (ICE on nested character constructors)

2008-09-21  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-21  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.
	* gfortran.dg/nested_array_constructor_6.f90: New test.

From-SVN: r140529

gcc/fortran/ChangeLog

 2008-09-21  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-21  Daniel Kraft  <d@domob.eu>
+
 	* decl.c (match_procedure_in_type): Changed misleading error message
 	for not yet implemented PROCEDURE(interface) syntax.
 

gcc/fortran/trans-array.c

@@ -1694,6 +1694,13 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
   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_loopinfo * loop, gfc_ss * ss, locus * where)
 	  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_loopinfo * loop, gfc_ss * ss, locus * where)
       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 decl, gfc_symbol * sym, tree fnbody)
   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 decl, gfc_symbol * sym, tree fnbody)
 
   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, tree body)
 
   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 * sym, tree tmpdesc, tree body)
 
   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, gfc_expr * expr, gfc_ss * ss)
       break;
     }
 
-
   gfc_init_loopinfo (&loop);
 
   /* Associate the SS with the loop.  */
@@ -4872,7 +4884,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       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 * sym, tree body)
   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);
     }
 

gcc/fortran/trans-decl.c

@@ -2583,7 +2583,7 @@ gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
   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_symbol * sym, tree fnbody)
   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);
 

gcc/fortran/trans-expr.c

@@ -241,17 +241,102 @@ 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;
+
+	  flatten_array_ctors_without_strlen (new_expr);
+	  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 +2177,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
 
   /* 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)

gcc/fortran/trans.h

@@ -340,7 +340,7 @@ tree gfc_conv_string_tmp (gfc_se *, tree, 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 *);
 

gcc/testsuite/ChangeLog

 2008-09-21  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.
+	* gfortran.dg/nested_array_constructor_6.f90: New test.
+
+2008-09-21  Daniel Kraft  <d@domob.eu>
+
 	* gfortran.dg/typebound_proc_4.f03: Changed expected error for not
 	yet implemented PROCEDURE(interface).
 

gcc/testsuite/gfortran.dg/nested_array_constructor_1.f90

+! { 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

gcc/testsuite/gfortran.dg/nested_array_constructor_2.f90

+! { 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

gcc/testsuite/gfortran.dg/nested_array_constructor_3.f90

+! { 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

gcc/testsuite/gfortran.dg/nested_array_constructor_4.f90

+! { 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

gcc/testsuite/gfortran.dg/nested_array_constructor_5.f90

+! { 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

gcc/testsuite/gfortran.dg/nested_array_constructor_6.f90

+! { dg-do compile }
+
+! PR fortran/35846
+! Nested three levels deep.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+character(len=3) :: c(3)
+c = 'a'
+c = (/ (/ 'A'//(/ trim(c(1)), 'a' /)/)//'c', 'dcd' /)
+print *, c(1)
+print *, c(2)
+print *, c(3)
+end