re PR fortran/34955 (transfer_assumed_size_1.f90: Valgrind error: invalid read of size 3)

2009-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34955
	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Has
	been absorbed into gfc_conv_intrinsic_transfer. All
	references to it in trans-intrinsic.c have been changed
	accordingly.  PR fixed by using a temporary for scalar
	character transfer, when the source is shorter than the
	destination.

2009-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34955
	* gfortran.dg/transfer_intrinsic_1.f90: New test.
	* gfortran.dg/transfer_intrinsic_2.f90: New test.

From-SVN: r143462

gcc/fortran/ChangeLog

 2009-01-17  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/34955
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Has
+	been absorbed into gfc_conv_intrinsic_transfer. All
+	references to it in trans-intrinsic.c have been changed
+	accordingly.  PR fixed by using a temporary for scalar
+	character transfer, when the source is shorter than the
+	destination.
+
+2009-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/38657
 	* module.c (write_common_0): Revert patch of 2009-01-05.
 

gcc/fortran/trans-intrinsic.c

@@ -3615,18 +3615,27 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
 }
 
 
-/* Array transfer statement.
-     DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
-   where:
-     typeof<DEST> = typeof<MOLD>
-   and:
-     N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
+/* Generate code for the TRANSFER intrinsic:
+	For scalar results:
+	  DEST = TRANSFER (SOURCE, MOLD)
+	where:
+	  typeof<DEST> = typeof<MOLD>
+	and:
+	  MOLD is scalar.
+
+	For array results:
+	  DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
+	where:
+	  typeof<DEST> = typeof<MOLD>
+	and:
+	  N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
 	      sizeof (DEST(0) * SIZE).  */
-
 static void
-gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 {
   tree tmp;
+  tree tmpdecl;
+  tree ptr;
   tree extent;
   tree source;
   tree source_type;
@@ -3645,14 +3654,27 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   gfc_ss_info *info;
   stmtblock_t block;
   int n;
+  bool scalar_mold;
 
-  gcc_assert (se->loop);
-  info = &se->ss->data.info;
+  info = NULL;
+  if (se->loop)
+    info = &se->ss->data.info;
 
   /* Convert SOURCE.  The output from this stage is:-
 	source_bytes = length of the source in bytes
 	source = pointer to the source data.  */
   arg = expr->value.function.actual;
+
+  /* Ensure double transfer through LOGICAL preserves all
+     the needed bits.  */
+  if (arg->expr->expr_type == EXPR_FUNCTION
+	&& arg->expr->value.function.esym == NULL
+	&& arg->expr->value.function.isym != NULL
+	&& arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
+	&& arg->expr->ts.type == BT_LOGICAL
+	&& expr->ts.type != arg->expr->ts.type)
+    arg->expr->value.function.name = "__transfer_in_transfer";
+
   gfc_init_se (&argse, NULL);
   ss = gfc_walk_expr (arg->expr);
 
@@ -3682,8 +3704,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
 
       /* Repack the source if not a full variable array.  */
-      if (!(arg->expr->expr_type == EXPR_VARIABLE
-	      && arg->expr->ref->u.ar.type == AR_FULL))
+      if (arg->expr->expr_type == EXPR_VARIABLE
+	      && arg->expr->ref->u.ar.type != AR_FULL)
 	{
 	  tmp = build_fold_addr_expr (argse.expr);
 
@@ -3750,6 +3772,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   gfc_init_se (&argse, NULL);
   ss = gfc_walk_expr (arg->expr);
 
+  scalar_mold = arg->expr->rank == 0;
+
   if (ss == gfc_ss_terminator)
     {
       gfc_conv_expr_reference (&argse, arg->expr);
@@ -3763,6 +3787,9 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
     }
 
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+
   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
     {
       /* If this TRANSFER is nested in another TRANSFER, use a type
@@ -3799,14 +3826,14 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   else
     tmp = NULL_TREE;
 
+  /* Separate array and scalar results.  */
+  if (scalar_mold && tmp == NULL_TREE)
+    goto scalar_transfer;
+
   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
   if (tmp != NULL_TREE)
-    {
-      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
-			 tmp, dest_word_len);
-      tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
-			 tmp, source_bytes);
-    }
+    tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+		       tmp, dest_word_len);
   else
     tmp = source_bytes;
 
@@ -3847,9 +3874,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   se->loop->to[n] = upper;
 
   /* Build a destination descriptor, using the pointer, source, as the
-     data field.  This is already allocated so set callee_alloc.
-     FIXME callee_alloc is not set!  */
-
+     data field.  */
   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
 			       info, mold_type, NULL_TREE, false, true, false,
 			       &expr->where);
@@ -3863,72 +3888,71 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
 			 3,
 			 tmp,
 			 fold_convert (pvoid_type_node, source),
-			 size_bytes);
+			 fold_build2 (MIN_EXPR, gfc_array_index_type,
+				      size_bytes, source_bytes));
   gfc_add_expr_to_block (&se->pre, tmp);
 
   se->expr = info->descriptor;
   if (expr->ts.type == BT_CHARACTER)
     se->string_length = dest_word_len;
-}
 
+  return;
 
-/* Scalar transfer statement.
-   TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
+/* Deal with scalar results.  */
+scalar_transfer:
+  extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
+			dest_word_len, source_bytes);
 
-static void
-gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
-{
-  gfc_actual_arglist *arg;
-  gfc_se argse;
-  tree type;
-  tree ptr;
-  gfc_ss *ss;
-  tree tmpdecl, tmp;
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      tree direct;
+      tree indirect;
 
-  /* Get a pointer to the source.  */
-  arg = expr->value.function.actual;
-  ss = gfc_walk_expr (arg->expr);
-  gfc_init_se (&argse, NULL);
-  if (ss == gfc_ss_terminator)
-    gfc_conv_expr_reference (&argse, arg->expr);
-  else
-    gfc_conv_array_parameter (&argse, arg->expr, ss, 1, NULL, NULL);
-  gfc_add_block_to_block (&se->pre, &argse.pre);
-  gfc_add_block_to_block (&se->post, &argse.post);
-  ptr = argse.expr;
+      ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
+      tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
+				"transfer");
 
-  arg = arg->next;
-  type = gfc_typenode_for_spec (&expr->ts);
-  if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
-    {
-      /* If this TRANSFER is nested in another TRANSFER, use a type
-	 that preserves all bits.  */
-      if (expr->ts.type == BT_LOGICAL)
-	type = gfc_get_int_type (expr->ts.kind);
-    }
+      /* If source is longer than the destination, use a pointer to
+	 the source directly.  */
+      gfc_init_block (&block);
+      gfc_add_modify (&block, tmpdecl, ptr);
+      direct = gfc_finish_block (&block);
 
-  if (expr->ts.type == BT_CHARACTER)
-    {
-      ptr = convert (build_pointer_type (type), ptr);
-      gfc_init_se (&argse, NULL);
-      gfc_conv_expr (&argse, arg->expr);
-      gfc_add_block_to_block (&se->pre, &argse.pre);
-      gfc_add_block_to_block (&se->post, &argse.post);
-      se->expr = ptr;
-      se->string_length = argse.string_length;
+      /* Otherwise, allocate a string with the length of the destination
+	 and copy the source into it.  */
+      gfc_init_block (&block);
+      tmp = gfc_get_pchar_type (expr->ts.kind);
+      tmp = gfc_call_malloc (&block, tmp, dest_word_len);
+      gfc_add_modify (&block, tmpdecl,
+		      fold_convert (TREE_TYPE (ptr), tmp));
+      tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+			     fold_convert (pvoid_type_node, tmpdecl),
+			     fold_convert (pvoid_type_node, ptr),
+			     extent);
+      gfc_add_expr_to_block (&block, tmp);
+      indirect = gfc_finish_block (&block);
+
+      /* Wrap it up with the condition.  */
+      tmp = fold_build2 (LE_EXPR, boolean_type_node,
+			 dest_word_len, source_bytes);
+      tmp = build3_v (COND_EXPR, tmp, direct, indirect);
+      gfc_add_expr_to_block (&se->pre, tmp);
+
+      se->expr = tmpdecl;
+      se->string_length = dest_word_len;
     }
   else
     {
-      tree moldsize;
-      tmpdecl = gfc_create_var (type, "transfer");
-      moldsize = size_in_bytes (type);
+      tmpdecl = gfc_create_var (mold_type, "transfer");
+
+      ptr = convert (build_pointer_type (mold_type), source);
 
       /* Use memcpy to do the transfer.  */
       tmp = build_fold_addr_expr (tmpdecl);
       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
 			     fold_convert (pvoid_type_node, tmp),
 			     fold_convert (pvoid_type_node, ptr),
-			     moldsize);
+			     extent);
       gfc_add_expr_to_block (&se->pre, tmp);
 
       se->expr = tmpdecl;
@@ -4828,23 +4852,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 	  gfc_advance_se_ss_chain (se);
 	}
       else
-	{
-	  /* Ensure double transfer through LOGICAL preserves all
-	     the needed bits.  */
-	  gfc_expr *source = expr->value.function.actual->expr;
-	  if (source->expr_type == EXPR_FUNCTION
-	      && source->value.function.esym == NULL
-	      && source->value.function.isym != NULL
-	      && source->value.function.isym->id == GFC_ISYM_TRANSFER
-	      && source->ts.type == BT_LOGICAL
-	      && expr->ts.type != source->ts.type)
-	    source->value.function.name = "__transfer_in_transfer";
-
-	  if (se->ss)
-	    gfc_conv_intrinsic_array_transfer (se, expr);
-	  else
-	    gfc_conv_intrinsic_transfer (se, expr);
-	}
+	gfc_conv_intrinsic_transfer (se, expr);
       break;
 
     case GFC_ISYM_TTYNAM:

gcc/testsuite/ChangeLog

 2009-01-17  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/34955
+	* gfortran.dg/transfer_intrinsic_1.f90: New test.
+	* gfortran.dg/transfer_intrinsic_2.f90: New test.
+
+2009-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/38657
 	* gfortran.dg/module_commons_3.f90: Remove
 

gcc/testsuite/gfortran.dg/char_cast_1.f90

@@ -25,7 +25,7 @@
     return
   end function Upper
 end
-! The sign that all is well is that [S.5][1] appears twice.
-! Platform dependent variations are [S$5][1], [__S_5][1], [S___5][1]
-! { dg-final { scan-tree-dump-times "5\\\]\\\[1\\\]" 2 "original" } }
+! The sign that all is well is that [S.6][1] appears twice.
+! Platform dependent variations are [S$6][1], [__S_6][1], [S___6][1]
+! { dg-final { scan-tree-dump-times "6\\\]\\\[1\\\]" 2 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/transfer_intrinsic_1.f90

+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Check the fix for PR34955 in which three bytes would be copied
+! from bytes by TRANSFER, instead of the required two.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+subroutine BytesToString(bytes, string)
+    type ByteType
+      integer(kind=1) :: singleByte
+    end type
+    type (ByteType) :: bytes(2)
+    character(len=*) :: string
+    string = transfer(bytes, string)
+  end subroutine
+! { dg-final { scan-tree-dump-times "MIN_EXPR" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/transfer_intrinsic_2.f90

+! { dg-do run }
+!
+! Check the fix for PR34955 in which three bytes would be copied
+! from bytes by TRANSFER, instead of the required two and the
+! resulting string length would be incorrect.
+!
+! Contributed by Dominique Dhumieres  <dominiq@lps.ens.fr>
+!
+  character(len = 1)  :: string = "z"
+  character(len = 20) :: tmp = ""
+  tmp = Upper ("abcdefgh")
+  if (trim(tmp) .ne. "ab") call abort ()
+contains
+  Character (len = 20) Function Upper (string)
+    Character(len = *) string
+    integer :: ij
+    i = size (transfer (string,"xy",len (string)))
+    if (i /= len (string)) call abort ()
+    Upper = ""
+    Upper(1:2) = &
+    transfer (merge (transfer (string,"xy",len (string)),    &
+      string(1:2), .true.), "xy")
+    return
+  end function Upper
+end