[patch, fortran] A partial fix for PR31610 (ICE with transfer)

[Brooks Moses <brooks dot moses at codesourcery dot com>]

:ADDPATCH fortran:

PR 31610 is turning out to be a real bear to fix, despite being 
essentially a one-line testcase.  This patch fixes three (!) somewhat 
independent problems that were causing it to fail, but there's still 
more to go -- and I'd appreciate some advice on the remainder from 
someone who knows the scalarizer fairly well; I'm just about stuck; see 
the PR for details.  (Though Andrew Pinski mentioned to me that PR 31608 
seems related, so I'll try poking at that next.)

The first solved problem is that, if the mold argument to transfer is an 
uninitialized variable, then it doesn't have a value, and 
gfc_target_expr_size ICEs when trying to access 
e->value.character.length.  That's easy enough to fix; this checks the 
typespec for a length first, and then uses the value length if that 
doesn't exist.

The second problem is that, if the source argument to transfer is an 
EXPR_FUNCTION expression and gfc_is_constant_expr(source) is true, we 
try to simplify it.  This does not work, and quickly leads to an ICE.  I 
fixed that by returning NULL unless source is an EXPR_ARRAY, 
EXPR_CONSTANT, or EXPR_STRUCTURE expression.

The third problem is that, when the result is a character array and the 
mold is a character scalar, we also get an ICE.  The problem here is 
that a character array expression needs to have a ts.cl that's non-NULL, 
otherwise we get an ICE when the trans-* part of the front end tries to 
set parts of it.  However, when we're transferring something to a 
character array, we currently don't bother creating result->ts.cl.  If 
the mold is a character array, we'll get a copy of mold->ts.cl and then 
things work, but if the mold is a character scalar without a ts.cl, then 
we have problems.

A related issue is that, when I initially wrote this, I set the 
result->value.character.length value to pass the character length to the 
gfc_target_interpret_expr function, even though character arrays aren't 
supposed to have values directly.  Correcting that to do things "right" 
by creating a result->ts.cl if it doesn't exist, and putting the 
character length in ts.cl->length where it should be, fixes this 
particular bug.

Oh, and a fourth problem that this patch fixes: If the result is larger 
than the source, we end up accessing uninitialized parts of the buffer. 
 I fixed this by memsetting the buffer to zero when it's created, 
though (since the padding is specified as "machine dependent" rather 
than zero) it might be more appropriate to use something else to avoid 
giving people a false sense of security.

-------------------------------------------------------------------
2007-05-28  Brooks Moses  <brooks.moses@codesourcery.com>

	PR fortran/31610
	* target-memory.c (size_character): Check for the typespec
	length as well as the value length.
	(gfc_target_expr_size): Pass the whole expression to
	size_character.
	(encode_character): Check the buffer size against the
	length directly.
	(interpret_array): Use the typespec length, not the value
	length, for character array result expressions.
	(gfc_interpret_character): Pass the whole result to
	size_character.
	* simplify.c (gfc_simplify_transfer): Only simplify if
	arguments are ARRAY, STRUCTURE, or CONSTANT.  Pass character
	lengths for array results in ts.cl->length, not in
	value.character.length.  Set the buffer to zero before use,
	to avoid accessing uninitialized memory.

-------------------------------------------------------------------
2007-05-28  Brooks Moses  <brooks.moses@codesourcery.com>

	PR fortran/31610
	* gfortran.dg/transfer_simplify_5.f90: New test.

-------------------------------------------------------------------

Regression-tested on powerpc-apple-darwin8.9.0.  Ok for trunk?

- Brooks
Index: target-memory.c
===================================================================
--- target-memory.c	(revision 125141)
+++ target-memory.c	(working copy)
@@ -74,9 +74,16 @@ size_logical (int kind)
 
 
 static size_t
-size_character (int length)
+size_character (gfc_expr *e)
 {
-  return length;
+  /* Return the typespec length, if it exists.  */
+  if (e->ts.cl != NULL && e->ts.cl->length != NULL
+      && e->ts.cl->length->expr_type == EXPR_CONSTANT
+      && e->ts.cl->length->ts.type == BT_INTEGER)
+    return (int)mpz_get_ui (e->ts.cl->length->value.integer);
+
+  /* Otherwise, return the constructor length.  */
+  return e->value.character.length;
 }
 
 
@@ -101,7 +108,7 @@ gfc_target_expr_size (gfc_expr *e)
     case BT_LOGICAL:
       return size_logical (e->ts.kind);
     case BT_CHARACTER:
-      return size_character (e->value.character.length);
+      return size_character (e);
     case BT_HOLLERITH:
       return e->representation.length;
     case BT_DERIVED:
@@ -178,7 +185,7 @@ static int
 encode_character (int length, char *string, unsigned char *buffer,
 		  size_t buffer_size)
 {
-  gcc_assert (buffer_size >= size_character (length));
+  gcc_assert (buffer_size >= (size_t) length);
   memcpy (buffer, string, length);
   return length;
 }
@@ -289,7 +296,8 @@ interpret_array (unsigned char *buffer, 
       tail->expr->ts = result->ts;
 
       if (tail->expr->ts.type == BT_CHARACTER)
-	tail->expr->value.character.length = result->value.character.length;
+	tail->expr->value.character.length
+	  = (int)mpz_get_ui (result->ts.cl->length->value.integer);
 
       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 					tail->expr);
@@ -355,7 +363,7 @@ gfc_interpret_character (unsigned char *
     result->value.character.length =
       (int)mpz_get_ui (result->ts.cl->length->value.integer);
 
-  gcc_assert (buffer_size >= size_character (result->value.character.length));
+  gcc_assert (buffer_size >= size_character (result));
   result->value.character.string =
     gfc_getmem (result->value.character.length + 1);
   memcpy (result->value.character.string, buffer,
Index: simplify.c
===================================================================
--- simplify.c	(revision 125106)
+++ simplify.c	(working copy)
@@ -3875,8 +3875,15 @@ gfc_simplify_transfer (gfc_expr *source,
   mpz_t tmp;
   unsigned char *buffer;
 
-  if (!gfc_is_constant_expr (source)
-	|| !gfc_is_constant_expr (size))
+  if ((source->expr_type != EXPR_ARRAY && source->expr_type != EXPR_CONSTANT
+       && source->expr_type != EXPR_STRUCTURE)
+      || !gfc_is_constant_expr (source))
+    return NULL;
+
+  if (size && ((size->expr_type != EXPR_ARRAY
+		&& size->expr_type != EXPR_CONSTANT
+		&& size->expr_type != EXPR_STRUCTURE)
+	       || !gfc_is_constant_expr (size)))
     return NULL;
 
   /* Calculate the size of the source.  */
@@ -3895,13 +3902,8 @@ gfc_simplify_transfer (gfc_expr *source,
 		 ? mold->value.constructor->expr
 		 : mold;
 
-  /* Set result character length, if needed.  Note that this needs to be
-     set even for array expressions, in order to pass this information into 
-     gfc_target_interpret_expr.  */
-  if (result->ts.type == BT_CHARACTER)
-    result->value.character.length = mold_element->value.character.length;
-  
-  /* Set the number of elements in the result, and determine its size.  */
+  /* Set the number of elements in the result, determine its size,
+     and set the character length if needed.  */
   result_elt_size = gfc_target_expr_size (mold_element);
   if (mold->expr_type == EXPR_ARRAY || size)
     {
@@ -3923,16 +3925,32 @@ gfc_simplify_transfer (gfc_expr *source,
       mpz_init_set_ui (result->shape[0], result_length);
 
       result_size = result_length * result_elt_size;
+      
+      if (result->ts.type == BT_CHARACTER && result->ts.cl == NULL)
+	{
+	  result->ts.cl = gfc_get_charlen();
+          result->ts.cl->next = gfc_current_ns->cl_list;
+          gfc_current_ns->cl_list = result->ts.cl;
+	  result->ts.cl->length
+	    = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
+				   &source->where);
+	  mpz_init_set_ui (result->ts.cl->length->value.integer,
+			   mold_element->value.character.length);
+	}
     }
   else
     {
       result->rank = 0;
       result_size = result_elt_size;
+
+      if (result->ts.type == BT_CHARACTER)
+	result->value.character.length = mold_element->value.character.length;
     }
 
   /* Allocate the buffer to store the binary version of the source.  */
   buffer_size = MAX (source_size, result_size);
   buffer = (unsigned char*)alloca (buffer_size);
+  memset (buffer, 0, buffer_size);
 
   /* Now write source to the buffer.  */
   gfc_target_encode_expr (source, buffer, buffer_size);

! { dg-do compile }
! Various problems found in solving PR 31610:

  character :: c

! Check that the length of an uninitialized scalar is handled
! properly.
  write(*,*) transfer("ab", c)

! Check that we don't have problems with constant function arguments.
  write(*,*) transfer (merge ( (/ "a", "b" /), "c", (/ .true., .false. /) ), &
    "ac" )

! Check that character lengths get set correctly when the result
! is an array and the mold is a scalar.
  write(*,*) transfer("ABCDE", "x", 5)
end