2006-03-22 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/31193
	* trans-intrinsic.c (gfc_size_in_bytes): Remove function.
	(gfc_conv_intrinsic_array_transfer): Remove calls to previous.
	Explicitly extract TREE_TYPEs for source and mold.  Use these
	to calculate length of source and mold, except for characters,
	where the se string_length is used.  For mold, the TREE_TYPE is
	recalculated using gfc_get_character_type_len so that the
	result is correctly cast for character literals and substrings.
	Do not use gfc_typenode_for_spec for the final cast.

2006-03-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31193
	* gfortran.dg/transfer_array_intrinsic_3.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@123131 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c32304bf9529362d76d4f462adbd0a9977e4ba49..4e366aa0274f6f5719c91c886536805d36c18fd0 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2006-03-22  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/31193
+       * trans-intrinsic.c (gfc_size_in_bytes): Remove function.
+       (gfc_conv_intrinsic_array_transfer): Remove calls to previous.
+       Explicitly extract TREE_TYPEs for source and mold.  Use these
+       to calculate length of source and mold, except for characters,
+       where the se string_length is used.  For mold, the TREE_TYPE is
+       recalculated using gfc_get_character_type_len so that the
+       result is correctly cast for character literals and substrings.
+       Do not use gfc_typenode_for_spec for the final cast.
+
 2007-03-22  Tobias Schlüter  <tobi@gcc.gnu.org>
 
        PR fortran/20897

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 58c4131eea702362eeedc3692971e5ebee6a68fb..4465030ab5ef1fd14849e31cde92fc20fad61891 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2790,30 +2790,6 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
 }
 
 
-/* A helper function for gfc_conv_intrinsic_array_transfer to compute
-   the size of tree expressions in bytes.  */
-static tree
-gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
-{
-  tree tmp;
-
-  if (e->ts.type == BT_CHARACTER)
-    tmp = se->string_length;
-  else
-    {
-      if (e->rank)
-       {
-         tmp = gfc_get_element_type (TREE_TYPE (se->expr));
-         tmp = size_in_bytes (tmp);
-       }
-      else
-       tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
-    }
-
-  return fold_convert (gfc_array_index_type, tmp);
-}
-
-
 /* Array transfer statement.
      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
    where:
@@ -2828,7 +2804,9 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   tree tmp;
   tree extent;
   tree source;
+  tree source_type;
   tree source_bytes;
+  tree mold_type;
   tree dest_word_len;
   tree size_words;
   tree size_bytes;
@@ -2861,8 +2839,14 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
       gfc_conv_expr_reference (&argse, arg->expr);
       source = argse.expr;
 
+      source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+
       /* Obtain the source word length.  */
-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      if (arg->expr->ts.type == BT_CHARACTER)
+       tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+       tmp = fold_convert (gfc_array_index_type,
+                           size_in_bytes (source_type)); 
     }
   else
     {
@@ -2870,6 +2854,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
       source = gfc_conv_descriptor_data_get (argse.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
@@ -2898,7 +2883,11 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
        }
 
       /* Obtain the source word length.  */
-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      if (arg->expr->ts.type == BT_CHARACTER)
+       tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+       tmp = fold_convert (gfc_array_index_type,
+                           size_in_bytes (source_type)); 
 
       /* Obtain the size of the array in bytes.  */
       extent = gfc_create_var (gfc_array_index_type, NULL);
@@ -2924,7 +2913,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
 
-  /* Now convert MOLD.  The sole output is:
+  /* Now convert MOLD.  The outputs are:
+       mold_type = the TREE type of MOLD
        dest_word_len = destination word length in bytes.  */
   arg = arg->next;
 
@@ -2934,20 +2924,25 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   if (ss == gfc_ss_terminator)
     {
       gfc_conv_expr_reference (&argse, arg->expr);
-
-      /* Obtain the source word length.  */
-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
     }
   else
     {
       gfc_init_se (&argse, NULL);
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
-
-      /* Obtain the source word length.  */
-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
     }
 
+  if (arg->expr->ts.type == BT_CHARACTER)
+    {
+      tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+    }
+  else
+    tmp = fold_convert (gfc_array_index_type,
+                       size_in_bytes (mold_type)); 
+ 
   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
 
@@ -3016,15 +3011,18 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   /* 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!  */
- 
-  tmp = gfc_typenode_for_spec (&expr->ts);
+
   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
-                              info, tmp, false, true, false);
+                              info, mold_type, false, true, false);
+
+  /* Cast the pointer to the result.  */
+  tmp = gfc_conv_descriptor_data_get (info->descriptor);
+  tmp = fold_convert (pvoid_type_node, tmp);
 
   /* Use memcpy to do the transfer.  */
   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
                         3,
-                        gfc_conv_descriptor_data_get (info->descriptor),
+                        tmp,
                         fold_convert (pvoid_type_node, source),
                         size_bytes);
   gfc_add_expr_to_block (&se->pre, tmp);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d993a15c1f6ae93bff1ea626026349eec8f72bc7..6f551d028dc88d3d41ef875cfbbab269ec001c0e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2006-03-22  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/31193
+       * gfortran.dg/transfer_array_intrinsic_3.f90: New test.
+
 2007-03-22  Tobias Schlüter  <tobi@gcc.gnu.org>
 
        PR fortran/20897

diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_3.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_3.f90
new file mode 100644 (file)
index 0000000..b97e840
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_3.f90
@@ -0,0 +1,36 @@
+! { dg-do run }\r
+! Tests fix for PR31193, in which the character length for MOLD in\r
+! case 1 below was not being translated correctly for character\r
+! constants and an ICE ensued.  The further cases are either checks\r
+! or new bugs that were found in the course of development cases 3 & 5.\r
+!\r
+! Contributed by Brooks Moses <brooks@gcc.gnu.org>\r
+!\r
+function NumOccurances (string, chr, isel) result(n)\r
+  character(*),intent(in) :: string\r
+  character(1),intent(in) :: chr\r
+  integer :: isel\r
+!\r
+! return number of occurances of character in given string\r
+!\r
+    select case (isel)\r
+      case (1)\r
+      n=count(transfer(string, char(1), len(string))==chr)\r
+      case (2)\r
+      n=count(transfer(string, chr, len(string))==chr)\r
+      case (3)\r
+      n=count(transfer(string, "a", len(string))==chr)\r
+      case (4)\r
+      n=count(transfer(string, (/"a","b"/), len(string))==chr)\r
+      case (5)\r
+      n=count(transfer(string, string(1:1), len(string))==chr)\r
+    end select\r
+  return\r
+end\r
+\r
+  if (NumOccurances("abacadae", "a", 1) .ne. 4) call abort ()\r
+  if (NumOccurances("abacadae", "a", 2) .ne. 4) call abort ()\r
+  if (NumOccurances("abacadae", "a", 3) .ne. 4) call abort ()\r
+  if (NumOccurances("abacadae", "a", 4) .ne. 4) call abort ()\r
+  if (NumOccurances("abacadae", "a", 5) .ne. 4) call abort ()\r
+end\r