re PR fortran/31219 (ICE on array of character function results)

2007-05-26 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/31219
	* trans.h : Add no_function_call bitfield to gfc_se structure.
	Add stmtblock_t argument to prototype of get_array_ctor_strlen.
	* trans-array.c (get_array_ctor_all_strlen): New function.
	(get_array_ctor_strlen): Add new stmtblock_t argument and call
	new function for character elements that are not constants,
	arrays or variables.
	(gfc_conv_array_parameter): Call get_array_ctor_strlen to get
	good string length.
	* trans-intrinsic (gfc_conv_intrinsic_len): Add new argument
	to call of get_array_ctor_strlen.


2007-05-26 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/31219
	* gfortran.dg/array_constructor_17.f90: New test.

From-SVN: r125088

6 files changed, 121 insertions, 15 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index dfc1174..0d4a877 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2007-05-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31219
+	* trans.h : Add no_function_call bitfield to gfc_se structure.
+	Add stmtblock_t argument to prototype of get_array_ctor_strlen.
+	* trans-array.c (get_array_ctor_all_strlen): New function.
+	(get_array_ctor_strlen): Add new stmtblock_t argument and call
+	new function for character elements that are not constants,
+	arrays or variables.
+	(gfc_conv_array_parameter): Call get_array_ctor_strlen to get
+	good string length.
+	* trans-intrinsic (gfc_conv_intrinsic_len): Add new argument
+	to call of get_array_ctor_strlen.
+
 2007-05-25  Kazu Hirata  <kazu@codesourcery.com>
 
 	* intrinsic.texi: Fix typos.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6c7ea6c..cda9f93 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1366,11 +1366,54 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
 }
 
 
+/* A catch-all to obtain the string length for anything that is not a
+   constant, array or variable.  */
+static void
+get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
+{
+  gfc_se se;
+  gfc_ss *ss;
+
+  /* Don't bother if we already know the length is a constant.  */
+  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.  */
+      gfc_conv_const_charlen (e->ts.cl);
+      *len = e->ts.cl->backend_decl;
+    }
+  else
+    {
+      /* Otherwise, be brutal even if inefficient.  */
+      ss = gfc_walk_expr (e);
+      gfc_init_se (&se, NULL);
+
+      /* No function call, in case of side effects.  */
+      se.no_function_call = 1;
+      if (ss == gfc_ss_terminator)
+	gfc_conv_expr (&se, e);
+      else
+	gfc_conv_expr_descriptor (&se, e, ss);
+
+      /* Fix the value.  */
+      *len = gfc_evaluate_now (se.string_length, &se.pre);
+
+      gfc_add_block_to_block (block, &se.pre);
+      gfc_add_block_to_block (block, &se.post);
+
+      e->ts.cl->backend_decl = *len;
+    }
+}
+
+
 /* Figure out the string length of a character array constructor.
    Returns TRUE if all elements are character constants.  */
 
 bool
-get_array_ctor_strlen (gfc_constructor * c, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
 {
   bool is_const;
   
@@ -1386,7 +1429,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len)
 	  break;
 
 	case EXPR_ARRAY:
-	  if (!get_array_ctor_strlen (c->expr->value.constructor, len))
+	  if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
 	    is_const = false;
 	  break;
 
@@ -1397,16 +1440,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len)
 
 	default:
 	  is_const = false;
-
-	  /* Hope that whatever we have possesses a constant character
-	     length!  */
-	  if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl)
-	    {
-	      gfc_conv_const_charlen (c->expr->ts.cl);
-	      *len = c->expr->ts.cl->backend_decl;
-	    }
-	  /* TODO: For now we just ignore anything we don't know how to
-	     handle, and hope we can figure it out a different way.  */
+	  get_array_ctor_all_strlen (block, c->expr, len);
 	  break;
 	}
     }
@@ -1597,10 +1631,13 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
   c = ss->expr->value.constructor;
   if (ss->expr->ts.type == BT_CHARACTER)
     {
-      bool const_string = get_array_ctor_strlen (c, &ss->string_length);
+      bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
       if (!ss->string_length)
 	gfc_todo_error ("complex character array constructors");
 
+      ss->expr->ts.cl->backend_decl = ss->string_length;
+
+
       type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
       if (const_string)
 	type = build_pointer_type (type);
@@ -4782,6 +4819,13 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
 		      && expr->ref->u.ar.type == AR_FULL);
   sym = full_array_var ? expr->symtree->n.sym : NULL;
 
+  if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
+    {
+      get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
+      expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
+      se->string_length = expr->ts.cl->backend_decl;
+    }
+
   /* Is this the result of the enclosing procedure?  */
   this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
   if (this_array_result
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 75b5a4c..d814b28 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2537,7 +2537,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
       /* Obtain the string length from the function used by
          trans-array.c(gfc_trans_array_constructor).  */
       len = NULL_TREE;
-      get_array_ctor_strlen (arg->value.constructor, &len);
+      get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
       break;
 
     case EXPR_VARIABLE:
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index da4b0c1..f2a5d44 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -72,6 +72,9 @@ typedef struct gfc_se
      are NULL.  Used by intrinsic size.  */
   unsigned data_not_needed:1;
 
+  /* If set, gfc_conv_function_call does not put byref calls into se->pre.  */
+  unsigned no_function_call:1;
+
   /* Scalarization parameters.  */
   struct gfc_se *parent;
   struct gfc_ss *ss;
@@ -434,7 +437,7 @@ extern GTY(()) tree gfc_static_ctors;
 void gfc_generate_constructors (void);
 
 /* Get the string length of an array constructor.  */
-bool get_array_ctor_strlen (gfc_constructor *, tree *);
+bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *);
 
 /* Generate a runtime error check.  */
 void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 66ba361..0c99b3c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-05-26  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31219
+	* gfortran.dg/array_constructor_17.f90: New test.
+
 2007-05-25  Andrew Pinski  <andrew_pinski@playstation.sony.com>
 
 	PR tree-opt/32090
diff --git a/gcc/testsuite/gfortran.dg/array_constructor_17.f90 b/gcc/testsuite/gfortran.dg/array_constructor_17.f90
new file mode 100644
index 0000000..3ce7a91
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_constructor_17.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! Tests the fix for PR31219, in which the character length of
+! the functions in the array constructor was not being obtained
+! correctly and this caused an ICE.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+  INTEGER :: J
+  CHARACTER(LEN = 8) :: str
+  J = 3
+  write (str,'(2A4)') (/( F(I, J), I = 1, 2)/)
+  IF (str .NE. " ODD EVE") call abort ()
+
+! Comment #1 from F-X Coudert (noted by T. Burnus) that
+! actually exercises a different part of the bug.
+  call gee( (/g (3)/) )
+
+CONTAINS
+  FUNCTION F (K,J) RESULT(I)
+    INTEGER :: K, J
+    CHARACTER(LEN = J) :: I
+    IF (MODULO (K, 2) .EQ. 0) THEN
+       I = "EVEN"
+    ELSE
+       I = "ODD"
+    ENDIF
+  END FUNCTION
+
+  function g(k) result(i)
+    integer :: k
+    character(len = k) :: i
+    i = '1234'
+  end function
+  subroutine gee(a)
+    character(*),dimension(1) :: a
+    if(len (a) /= 3) call abort ()
+    if(a(1) /= '123') call abort ()
+  end subroutine gee
+
+END