re PR fortran/17298 (gfortran ICE: Not Implemented: Scalarization of…

re PR fortran/17298 (gfortran ICE: Not Implemented: Scalarization of non-elemental intrinsic: __transfer1)

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

	PR fortran/17298
	*trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New
	function to implement array valued TRANSFER intrinsic.
	(gfc_conv_intrinsic_function): Call the new function if TRANSFER
	and non-null se->ss.
	(gfc_walk_intrinsic_function): Treat TRANSFER as one of the
	special cases by calling gfc_walk_intrinsic_libfunc directly.

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

	PR fortran/17298
	* gfortran.dg/transfer_array_intrinsic_1.f90: New test.
	* gfortran.dg/transfer_array_intrinsic_2.f90: New test.

From-SVN: r112278

gcc/fortran/ChangeLog

+2006-03-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/17298
+	*trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New
+	function to implement array valued TRANSFER intrinsic.
+	(gfc_conv_intrinsic_function): Call the new function if TRANSFER
+	and non-null se->ss.
+	(gfc_walk_intrinsic_function): Treat TRANSFER as one of the
+	special cases by calling gfc_walk_intrinsic_libfunc directly.
+
 2006-03-21  Toon Moene  <toon@moene.indiv.nluug.nl>
 
 	* options.c (gfc_init_options): Initialize

gcc/fortran/trans-intrinsic.c

@@ -2461,6 +2461,221 @@ 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(:)),
+	      sizeof (DEST(0) * SIZE).  */
+
+static void
+gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+  tree extent;
+  tree source;
+  tree source_bytes;
+  tree dest_word_len;
+  tree size_words;
+  tree size_bytes;
+  tree upper;
+  tree lower;
+  tree stride;
+  tree stmt;
+  gfc_actual_arglist *arg;
+  gfc_se argse;
+  gfc_ss *ss;
+  gfc_ss_info *info;
+  stmtblock_t block;
+  int n;
+
+  gcc_assert (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;
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (arg->expr);
+
+  source_bytes = gfc_create_var (gfc_array_index_type, NULL);
+
+  /* Obtain the pointer to source and the length of source in bytes.  */
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (&argse, arg->expr);
+      source = argse.expr;
+
+      /* Obtain the source word length.  */
+      tmp = size_in_bytes(TREE_TYPE(TREE_TYPE (source)));
+      tmp =  fold_convert (gfc_array_index_type, tmp);
+    }
+  else
+    {
+      gfc_init_se (&argse, NULL);
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+      source = gfc_conv_descriptor_data_get (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))
+	{
+	  tmp = build_fold_addr_expr (argse.expr);
+	  tmp = gfc_chainon_list (NULL_TREE, tmp);
+	  source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
+	  source = gfc_evaluate_now (source, &argse.pre);
+
+	  /* Free the temporary.  */
+	  gfc_start_block (&block);
+	  tmp = convert (pvoid_type_node, source);
+	  tmp = gfc_chainon_list (NULL_TREE, tmp);
+	  tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+	  gfc_add_expr_to_block (&block, tmp);
+	  stmt = gfc_finish_block (&block);
+
+	  /* Clean up if it was repacked.  */
+	  gfc_init_block (&block);
+	  tmp = gfc_conv_array_data (argse.expr);
+	  tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
+	  tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+	  gfc_add_expr_to_block (&block, tmp);
+	  gfc_add_block_to_block (&block, &se->post);
+	  gfc_init_block (&se->post);
+	  gfc_add_block_to_block (&se->post, &block);
+	}
+
+      /* Obtain the source word length.  */
+      tmp = gfc_get_element_type (TREE_TYPE(argse.expr));
+      tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+
+      /* Obtain the size of the array in bytes.  */
+      extent = gfc_create_var (gfc_array_index_type, NULL);
+      for (n = 0; n < arg->expr->rank; n++)
+	{
+	  tree idx;
+	  idx = gfc_rank_cst[n];
+	  gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+	  stride = gfc_conv_descriptor_stride (argse.expr, idx);
+	  lower = gfc_conv_descriptor_lbound (argse.expr, idx);
+	  upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
+			upper, lower);
+	  gfc_add_modify_expr (&argse.pre, extent, tmp);
+	  tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+			extent, gfc_index_one_node);
+	  tmp = build2 (MULT_EXPR, gfc_array_index_type,
+			tmp, source_bytes);
+	}
+    }
+
+  gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+  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:
+	dest_word_len = destination word length in bytes.  */
+  arg = arg->next;
+
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (arg->expr);
+
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (&argse, arg->expr);
+      tmp = TREE_TYPE(TREE_TYPE (argse.expr));
+      tmp =  fold_convert (gfc_array_index_type, size_in_bytes(tmp));
+    }
+  else
+    {
+      gfc_init_se (&argse, NULL);
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+      tmp = gfc_get_element_type (TREE_TYPE(argse.expr));
+      tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+    }
+
+  dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
+
+  /* Finally convert SIZE, if it is present.  */
+  arg = arg->next;
+  size_words = gfc_create_var (gfc_array_index_type, NULL);
+
+  if (arg->expr)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_reference (&argse, arg->expr);
+      tmp = convert (gfc_array_index_type,
+			 build_fold_indirect_ref (argse.expr));
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+    }
+  else
+    tmp = NULL_TREE;
+
+  size_bytes = gfc_create_var (gfc_array_index_type, NULL);
+  if (tmp != NULL_TREE)
+    {
+      tmp = build2 (MULT_EXPR, gfc_array_index_type,
+		    tmp, dest_word_len);
+      tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
+    }
+  else
+    tmp = source_bytes;
+
+  gfc_add_modify_expr (&se->pre, size_bytes, tmp);
+  gfc_add_modify_expr (&se->pre, size_words,
+		       build2 (CEIL_DIV_EXPR, gfc_array_index_type,
+			       size_bytes, dest_word_len));
+
+  /* Evaluate the bounds of the result.  If the loop range exists, we have
+     to check if it is too large.  If so, we modify loop->to be consistent
+     with min(size, size(source)).  Otherwise, size is made consistent with
+     the loop range, so that the right number of bytes is transferred.*/
+  n = se->loop->order[0];
+  if (se->loop->to[n] != NULL_TREE)
+    {
+      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			 se->loop->to[n], se->loop->from[n]);
+      tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+		    tmp, gfc_index_one_node);
+      tmp = build2 (MIN_EXPR, gfc_array_index_type,
+		    tmp, size_words);
+      gfc_add_modify_expr (&se->pre, size_words, tmp);
+      gfc_add_modify_expr (&se->pre, size_bytes,
+			   build2 (MULT_EXPR, gfc_array_index_type,
+			   size_words, dest_word_len));
+      upper = build2 (PLUS_EXPR, gfc_array_index_type,
+		      size_words, se->loop->from[n]);
+      upper = build2 (MINUS_EXPR, gfc_array_index_type,
+		      upper, gfc_index_one_node);
+    }
+  else
+    {
+      upper = build2 (MINUS_EXPR, gfc_array_index_type,
+		      size_words, gfc_index_one_node);
+      se->loop->from[n] = gfc_index_zero_node;
+    }
+
+  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.  */
+  tmp = gfc_typenode_for_spec (&expr->ts);
+  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
+			       info, tmp, false, false, true);
+
+  tmp = fold_convert (pvoid_type_node, source);
+  gfc_conv_descriptor_data_set (&se->pre, info->descriptor, tmp);
+  se->expr = info->descriptor;
+  if (expr->ts.type == BT_CHARACTER)
+    se->string_length = dest_word_len;
+}
+
+
 /* Scalar transfer statement.
    TRANSFER (source, mold) = *(typeof<mold> *)&source.  */
 
@@ -2473,8 +2688,6 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   tree ptr;
   gfc_ss *ss;
 
-  gcc_assert (!se->ss);
-
   /* Get a pointer to the source.  */
   arg = expr->value.function.actual;
   ss = gfc_walk_expr (arg->expr);
@@ -3374,7 +3587,20 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_TRANSFER:
-      gfc_conv_intrinsic_transfer (se, expr);
+      if (se->ss)
+	{
+	  if (se->ss->useflags)
+	    {
+	      /* Access the previously obtained result.  */
+	      gfc_conv_tmp_array_ref (se);
+	      gfc_advance_se_ss_chain (se);
+	      break;
+	    }
+	  else
+	    gfc_conv_intrinsic_array_transfer (se, expr);
+	}
+      else
+	gfc_conv_intrinsic_transfer (se, expr);
       break;
 
     case GFC_ISYM_TTYNAM:
@@ -3558,6 +3784,9 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
     case GFC_ISYM_UBOUND:
       return gfc_walk_intrinsic_bound (ss, expr);
 
+    case GFC_ISYM_TRANSFER:
+      return gfc_walk_intrinsic_libfunc (ss, expr);
+
     default:
       /* This probably meant someone forgot to add an intrinsic to the above
          list(s) when they implemented it, or something's gone horribly wrong.

gcc/testsuite/ChangeLog

+2006-03-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/17298
+	* gfortran.dg/transfer_array_intrinsic_1.f90: New test.
+	* gfortran.dg/transfer_array_intrinsic_2.f90: New test.
+
 2006-03-21  Janis Johnson  <janis187@us.ibm.com>
 
 	* lib/gcc-dg.exp (cleanup-modules): New proc.

gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90

+! { dg-do run }
+! Tests the patch to implement the array version of the TRANSFER
+! intrinsic (PR17298).
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+
+   character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
+
+! tests numeric transfers(including PR testcase).
+
+   call test1 ()
+
+! tests numeric/character transfers.
+
+   call test2 ()
+
+! Test dummies, automatic objects and assumed character length.
+
+   call test3 (ch, ch, ch, 8)
+
+contains
+
+   subroutine test1 ()
+     complex(4) :: z = (1.0, 2.0)
+     real(4) :: cmp(2), a(4, 4)
+     integer(2) :: it(4, 2, 4), jt(32)
+
+! The PR testcase.
+
+     cmp = transfer (z, cmp) * 2.0
+     if (any (cmp .ne. (/2.0, 4.0/))) call abort ()
+
+! Check that size smaller than the source word length is OK.
+
+     z = (-1.0, -2.0)
+     cmp = transfer (z, cmp, 1) * 8.0
+     if (any (cmp .ne. (/-8.0, 4.0/))) call abort ()
+
+! Check multi-dimensional sources and that transfer works as an actual
+! argument of reshape.
+
+     a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
+     jt = transfer (a, it)
+     it = reshape (jt, (/4, 2, 4/))
+     if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
+
+   end subroutine test1
+
+   subroutine test2 ()
+     integer(4) :: y(4), z(2)
+     character(4) :: ch(4)
+     y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
+              + ishft (i + 3, 24), i = 65, 80 , 4)/)
+
+! Check source array sections in both directions.
+
+     ch = "wxyz"
+     ch = transfer (y(2:4:2), ch)
+     if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort ()
+     ch = "wxyz"
+     ch = transfer (y(4:2:-2), ch)
+     if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort ()
+
+! Check that a complete array transfers with size absent.
+
+     ch = transfer (y, ch)
+     if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
+
+! Check that a character array section is OK
+
+     z = transfer (ch(2:3), y)
+     if (any (z .ne. y(2:3))) call abort ()
+
+! Check dest array sections in both directions.
+
+     ch = "wxyz"
+     ch(3:4) = transfer (y, ch, 2)
+     if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort ()
+     ch = "wxyz"
+     ch(3:2:-1) = transfer (y, ch, 3)
+     if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort ()
+
+! Check that too large a value of size is cut off.
+
+     ch = "wxyz"
+     ch(1:2) = transfer (y, ch, 3)
+     if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort ()
+
+! Make sure that character to numeric is OK.
+
+     z = transfer (ch, y)
+     if (any (y(1:2) .ne. z)) call abort ()
+
+   end subroutine test2
+
+   subroutine test3 (ch1, ch2, ch3, clen)
+     integer clen
+     character(8) :: ch1(:)
+     character(*) :: ch2(2)
+     character(clen) :: ch3(2)
+     character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
+     integer(8) :: ic(2)
+     ic = transfer (cntrl, ic)
+
+! Check assumed shape.
+
+     if (any (ic .ne. transfer (ch1, ic))) call abort ()
+
+! Check assumed character length.
+
+     if (any (ic .ne. transfer (ch2, ic))) call abort ()
+
+! Check automatic character length.
+
+     if (any (ic .ne. transfer (ch3, ic))) call abort ()
+
+  end subroutine test3
+
+end

gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90

+! { dg-do run }
+! { dg-options "-fpack-derived" }
+   call test3()
+contains
+   subroutine test3 ()
+     type mytype
+       sequence
+       real(8) :: x = 3.14159
+       character(4) :: ch = "wxyz"
+       integer(2) :: i = 77
+     end type mytype
+     type(mytype) :: z(2)
+     character(1) :: c(32)
+     character(4) :: chr
+     real(8) :: a
+     integer(2) :: l
+     equivalence (a, c(15)), (chr, c(23)), (l, c(27))
+     c = transfer(z, c)
+     if (a .ne. z(1)%x) call abort ()
+     if (chr .ne. z(1)%ch) call abort ()
+     if (l .ne. z(1)%i) call abort ()
+   end subroutine test3
+end