[patch, fortran] PR 37721, warn about target > source in TRANSFER

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

the attached patch fixes PR 37721 by moving the check for TRANSFER size 
mismatches to checking, away from simplification.  That means that it is 
possible to check character MOLDs whose size is constant, but which 
aren't constant themselves.

I added the extra argument to gfc_target_interpret_expr because for a 
TRANSFER, we want a binary copy and not a conversion between wide and
normal characters.

Regression-tested.  OK for trunk?

	Thomas

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.

Index: gfortran.h
===================================================================
--- gfortran.h	(Revision 176933)
+++ gfortran.h	(Arbeitskopie)
@@ -2884,6 +2884,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 *);
Index: target-memory.c
===================================================================
--- target-memory.c	(Revision 176933)
+++ target-memory.c	(Arbeitskopie)
@@ -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;
+      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->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);
-        }
+	  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 buf
 
       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
       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
       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
 /* 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,
       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);
Index: target-memory.h
===================================================================
--- target-memory.h	(Revision 176933)
+++ target-memory.h	(Arbeitskopie)
@@ -41,7 +41,7 @@ int gfc_interpret_complex (int, unsigned char *, s
 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 *,
Index: check.c
===================================================================
--- check.c	(Revision 176933)
+++ check.c	(Arbeitskopie)
@@ -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
   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_try
 	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;
 }
 
Index: simplify.c
===================================================================
--- simplify.c	(Revision 176933)
+++ simplify.c	(Arbeitskopie)
@@ -6028,17 +6028,19 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr
   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,45 +6066,17 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr
     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;
-    }
+    result->rank = 0;
 
-  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);
-
   /* Allocate the buffer to store the binary version of the source.  */
   buffer_size = MAX (source_size, result_size);
   buffer = (unsigned char*)alloca (buffer_size);
@@ -6112,7 +6086,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr
   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;
 }

Attachment: transfer_check_2.f90
Description: Text document