re PR fortran/37211 (TRANSFER to characters: Size checking)

2011-08-05  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/37221
	* gfortran.h (gfc_calculate_transfer_sizes):  Add prototype.
	* target-memory.h (gfc_target_interpret_expr):  Add boolean
	argument wether to convert wide characters.
	* target-memory.c (gfc_target_expr_size):  Also return length
	of characters for non-constant expressions if these can be
	determined from the cl.
	(interpret_array):  Add argument for gfc_target_interpret_expr.
	(gfc_interpret_derived):  Likewise.
	(gfc_target_interpret_expr):  Likewise.
	* check.c:  Include target-memory.h.
	(gfc_calculate_transfer_sizes):  New function.
	(gfc_check_transfer):  When -Wsurprising is in force, calculate
	sizes and warn if result is larger than size (check moved from
	gfc_simplify_transfer).
	* simplify.c (gfc_simplify_transfer):  Use
	gfc_calculate_transfer_sizes.  Remove warning.

2011-08-05  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/37221
	* gfortran.dg/transfer_check_2.f90:  New test case.

From-SVN: r177486

8 files changed, 144 insertions, 49 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d794d14a..31696b3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,23 @@
+2011-08-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/37221
+	* gfortran.h (gfc_calculate_transfer_sizes):  Add prototype.
+	* target-memory.h (gfc_target_interpret_expr):  Add boolean
+	argument wether to convert wide characters.
+	* target-memory.c (gfc_target_expr_size):  Also return length
+	of characters for non-constant expressions if these can be
+	determined from the cl.
+	(interpret_array):  Add argument for gfc_target_interpret_expr.
+	(gfc_interpret_derived):  Likewise.
+	(gfc_target_interpret_expr):  Likewise.
+	* check.c:  Include target-memory.h.
+	(gfc_calculate_transfer_sizes):  New function.
+	(gfc_check_transfer):  When -Wsurprising is in force, calculate
+	sizes and warn if result is larger than size (check moved from
+	gfc_simplify_transfer).
+	* simplify.c (gfc_simplify_transfer):  Use
+	gfc_calculate_transfer_sizes.  Remove warning.
+
 2011-08-04  Richard Guenther  <rguenther@suse.de>
 
 	PR fortran/49957
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index a95865b..3d4f4c8 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -32,6 +32,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "gfortran.h"
 #include "intrinsic.h"
 #include "constructor.h"
+#include "target-memory.h"
 
 
 /* Make sure an expression is a scalar.  */
@@ -3864,11 +3865,68 @@ gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
   return SUCCESS;
 }
 
+/* Calculate the sizes for transfer, used by gfc_check_transfer and also
+   by gfc_simplify_transfer.  Return FAILURE if we cannot do so.  */
 
 gfc_try
-gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
-		    gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
+gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
+			      size_t *source_size, size_t *result_size,
+			      size_t *result_length_p)
+
+{
+  size_t result_elt_size;
+  mpz_t tmp;
+  gfc_expr *mold_element;
+
+  if (source->expr_type == EXPR_FUNCTION)
+    return FAILURE;
+
+    /* Calculate the size of the source.  */
+  if (source->expr_type == EXPR_ARRAY
+      && gfc_array_size (source, &tmp) == FAILURE)
+    return FAILURE;
+
+  *source_size = gfc_target_expr_size (source);
+
+  mold_element = mold->expr_type == EXPR_ARRAY
+		 ? gfc_constructor_first (mold->value.constructor)->expr
+		 : mold;
+
+  /* Determine the size of the element.  */
+  result_elt_size = gfc_target_expr_size (mold_element);
+  if (result_elt_size == 0)
+    return FAILURE;
+
+  if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
+    {
+      int result_length;
+
+      if (size)
+	result_length = (size_t)mpz_get_ui (size->value.integer);
+      else
+	{
+	  result_length = *source_size / result_elt_size;
+	  if (result_length * result_elt_size < *source_size)
+	    result_length += 1;
+	}
+
+      *result_size = result_length * result_elt_size;
+      if (result_length_p)
+	*result_length_p = result_length;
+    }
+  else
+    *result_size = result_elt_size;
+
+  return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
 {
+  size_t source_size;
+  size_t result_size;
+
   if (mold->ts.type == BT_HOLLERITH)
     {
       gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
@@ -3888,6 +3946,21 @@ gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
 	return FAILURE;
     }
 
+  if (!gfc_option.warn_surprising)
+    return SUCCESS;
+
+  /* If we can't calculate the sizes, we cannot check any more.
+     Return SUCCESS for that case.  */
+
+  if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+				    &result_size, NULL) == FAILURE)
+    return SUCCESS;
+
+  if (source_size < result_size)
+    gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
+		"source size %ld < result size %ld", &source->where,
+		(long) source_size, (long) result_size);
+
   return SUCCESS;
 }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index acfa9d4..34afae4 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2896,6 +2896,8 @@ int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
 
 /* check.c */
 gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
+gfc_try gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
+				      size_t*, size_t*, size_t*);
 
 /* class.c */
 void gfc_add_component_ref (gfc_expr *, const char *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 79b383a..e4ffc3b 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -6028,17 +6028,19 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
   gfc_expr *mold_element;
   size_t source_size;
   size_t result_size;
-  size_t result_elt_size;
   size_t buffer_size;
   mpz_t tmp;
   unsigned char *buffer;
+  size_t result_length;
+
 
   if (!gfc_is_constant_expr (source)
 	|| (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
 	|| !gfc_is_constant_expr (size))
     return NULL;
 
-  if (source->expr_type == EXPR_FUNCTION)
+  if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+				    &result_size, &result_length) == FAILURE)
     return NULL;
 
   /* Calculate the size of the source.  */
@@ -6064,44 +6066,16 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
     result->value.character.length = mold_element->value.character.length;
   
   /* Set the number of elements in the result, and determine its size.  */
-  result_elt_size = gfc_target_expr_size (mold_element);
-  if (result_elt_size == 0)
-    {
-      gfc_free_expr (result);
-      return NULL;
-    }
 
   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
     {
-      int result_length;
-
       result->expr_type = EXPR_ARRAY;
       result->rank = 1;
-
-      if (size)
-	result_length = (size_t)mpz_get_ui (size->value.integer);
-      else
-	{
-	  result_length = source_size / result_elt_size;
-	  if (result_length * result_elt_size < source_size)
-	    result_length += 1;
-	}
-
       result->shape = gfc_get_shape (1);
       mpz_init_set_ui (result->shape[0], result_length);
-
-      result_size = result_length * result_elt_size;
     }
   else
-    {
-      result->rank = 0;
-      result_size = result_elt_size;
-    }
-
-  if (gfc_option.warn_surprising && source_size < result_size)
-    gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
-		"source size %ld < result size %ld", &source->where,
-		(long) source_size, (long) result_size);
+    result->rank = 0;
 
   /* Allocate the buffer to store the binary version of the source.  */
   buffer_size = MAX (source_size, result_size);
@@ -6112,7 +6086,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
   gfc_target_encode_expr (source, buffer, buffer_size);
 
   /* And read the buffer back into the new expression.  */
-  gfc_target_interpret_expr (buffer, buffer_size, result);
+  gfc_target_interpret_expr (buffer, buffer_size, result, false);
 
   return result;
 }
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index b5c90a7..025bccf 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -103,16 +103,20 @@ gfc_target_expr_size (gfc_expr *e)
     case BT_LOGICAL:
       return size_logical (e->ts.kind);
     case BT_CHARACTER:
-      if (e->expr_type == EXPR_SUBSTRING && e->ref)
-        {
-          int start, end;
-
-          gfc_extract_int (e->ref->u.ss.start, &start);
-          gfc_extract_int (e->ref->u.ss.end, &end);
-          return size_character (MAX(end - start + 1, 0), e->ts.kind);
-        }
+      if (e->expr_type == EXPR_CONSTANT)
+	return size_character (e->value.character.length, e->ts.kind);
+      else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+	       && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	       && e->ts.u.cl->length->ts.type == BT_INTEGER)
+	{
+	  int length;
+
+	  gfc_extract_int (e->ts.u.cl->length, &length);
+	  return size_character (length, e->ts.kind);
+	}
       else
-        return size_character (e->value.character.length, e->ts.kind);
+	return 0;
+
     case BT_HOLLERITH:
       return e->representation.length;
     case BT_DERIVED:
@@ -330,7 +334,8 @@ interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 
       gfc_constructor_append_expr (&base, e, &result->where);
 
-      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
+      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e,
+					true);
     }
 
   result->value.constructor = base;
@@ -456,7 +461,7 @@ gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *resu
       e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where); 
       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
       c->n.component = cmp;
-      gfc_target_interpret_expr (buffer, buffer_size, e);
+      gfc_target_interpret_expr (buffer, buffer_size, e, true);
       e->ts.is_iso_c = 1;
       return int_size_in_bytes (ptr_type_node);
     }
@@ -506,7 +511,7 @@ gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *resu
       gcc_assert (ptr % 8 == 0);
       ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 
-      gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
+      gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
     }
     
   return int_size_in_bytes (type);
@@ -516,7 +521,7 @@ gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *resu
 /* Read a binary buffer to a constant expression.  */
 int
 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
-			   gfc_expr *result)
+			   gfc_expr *result, bool convert_widechar)
 {
   if (result->expr_type == EXPR_ARRAY)
     return interpret_array (buffer, buffer_size, result);
@@ -562,7 +567,7 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
       break;
     }
 
-  if (result->ts.type == BT_CHARACTER)
+  if (result->ts.type == BT_CHARACTER && convert_widechar)
     result->representation.string
       = gfc_widechar_to_char (result->value.character.string,
 			      result->value.character.length);
diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h
index 2a82a88..6ebffe8 100644
--- a/gcc/fortran/target-memory.h
+++ b/gcc/fortran/target-memory.h
@@ -41,7 +41,7 @@ int gfc_interpret_complex (int, unsigned char *, size_t, mpc_t);
 int gfc_interpret_logical (int, unsigned char *, size_t, int *);
 int gfc_interpret_character (unsigned char *, size_t, gfc_expr *);
 int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);
-int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *);
+int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *, bool);
 
 /* Merge overlapping equivalence initializers for trans-common.c. */
 size_t gfc_merge_initializers (gfc_typespec, gfc_expr *,
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 93bf7f9..3b5a17f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/37221
+	* gfortran.dg/transfer_check_2.f90:  New test case.
+
 2011-08-05  Jan Hubicka  <jh@suse.cz>
 
 	PR middle-end/49494
diff --git a/gcc/testsuite/gfortran.dg/transfer_check_2.f90 b/gcc/testsuite/gfortran.dg/transfer_check_2.f90
new file mode 100644
index 0000000..3f2e1bf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_check_2.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-options "-Wsurprising" }
+! PR 37221 - also warn about too-long MOLD for TRANSFER if not simplifying.
+! Test case based on contribution by Tobias Burnus.
+program main
+  character(len=10) :: str
+  integer :: i
+  str = transfer(65+66*2**8+67*2**16+68*2**24,str) ! { dg-warning "has partly undefined result" }
+  write (*,*) str(1:4)
+  i = 65+66*2**8+67*2**16+68*2**24
+  str = transfer(i,str)  ! { dg-warning "has partly undefined result" }
+  write (*,*) str(1:4)
+  str = transfer(i,str(1:4))
+  write (*,*) str(1:4)
+end program
+