trans-io.c (transfer_array_component): New function.

2004-09-16  Victor Leikehman  <lei@il.ibm.com>

	PR/15364
	* trans-io.c (transfer_array_component): New function.
	(transfer_expr): For array fields, call transfer_array_component.
testsuite/
	* gfortran.dg/der_array_io_1.f90: New test.
	* gfortran.dg/der_array_io_2.f90: New test.
	* gfortran.dg/der_array_io_3.f90: New test.

From-SVN: r87596

gcc/fortran/ChangeLog

@@ -1,3 +1,9 @@
+2004-09-16  Victor Leikehman  <lei@il.ibm.com>
+
+	PR/15364
+	* trans-io.c (transfer_array_component): New function.
+	(transfer_expr): For array fields, call transfer_array_component.
+
 2004-09-16  Kazu Hirata  <kazu@cs.umass.edu>
 
 	* gfortran.texi: Fix a typo.

gcc/fortran/trans-io.c

@@ -1140,6 +1140,96 @@ gfc_trans_dt_end (gfc_code * code)
   return gfc_finish_block (&block);
 }
 
+static void
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
+
+/* Given an array field in a derived type variable, generate the code
+   for the loop that iterates over array elements, and the code that
+   accesses those array elements.  Use transfer_expr to generate code
+   for transferring that element.  Because elements may also be
+   derived types, transfer_expr and transfer_array_component are mutually
+   recursive.  */
+
+static tree
+transfer_array_component (tree expr, gfc_component * cm)
+{
+  tree tmp;
+  stmtblock_t body;
+  stmtblock_t block;
+  gfc_loopinfo loop;
+  int n;
+  gfc_ss *ss;
+  gfc_se se;
+
+  gfc_start_block (&block);
+  gfc_init_se (&se, NULL);
+
+  /* Create and initialize Scalarization Status.  Unlike in
+     gfc_trans_transfer, we can't simply use gfc_walk_expr to take
+     care of this task, because we don't have a gfc_expr at hand.
+     Build one manually, as in gfc_trans_subarray_assign.  */
+
+  ss = gfc_get_ss ();
+  ss->type = GFC_SS_COMPONENT;
+  ss->expr = NULL;
+  ss->shape = gfc_get_shape (cm->as->rank);
+  ss->next = gfc_ss_terminator;
+  ss->data.info.dimen = cm->as->rank;
+  ss->data.info.descriptor = expr;
+  ss->data.info.data = gfc_conv_array_data (expr);
+  ss->data.info.offset = gfc_conv_array_offset (expr);
+  for (n = 0; n < cm->as->rank; n++)
+    {
+      ss->data.info.dim[n] = n;
+      ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
+      ss->data.info.stride[n] = gfc_index_one_node;
+
+      mpz_init (ss->shape[n]);
+      mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
+               cm->as->lower[n]->value.integer);
+      mpz_add_ui (ss->shape[n], ss->shape[n], 1);
+    }
+
+  /* Once we got ss, we use scalarizer to create the loop. */
+
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, ss);
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop);
+  gfc_mark_ss_chain_used (ss, 1);
+  gfc_start_scalarized_body (&loop, &body);
+
+  gfc_copy_loopinfo_to_se (&se, &loop);
+  se.ss = ss;
+
+  /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
+  se.expr = expr;
+  gfc_conv_tmp_array_ref (&se);
+
+  /* Now se.expr contains an element of the array.  Take the address and pass
+     it to the IO routines.  */
+  tmp = gfc_build_addr_expr (NULL, se.expr);
+  transfer_expr (&se, &cm->ts, tmp);
+
+  /* We are done now with the loop body.  Wrap up the scalarizer and
+     return. */
+
+  gfc_add_block_to_block (&body, &se.pre);
+  gfc_add_block_to_block (&body, &se.post);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  gfc_add_block_to_block (&block, &loop.pre);
+  gfc_add_block_to_block (&block, &loop.post);
+
+  gfc_cleanup_loop (&loop);
+
+  for (n = 0; n < cm->as->rank; n++)
+    mpz_clear (ss->shape[n]);
+  gfc_free (ss->shape);
+
+  return gfc_finish_block (&block);
+}
 
 /* Generate the call for a scalar transfer node.  */
 
@@ -1177,11 +1267,19 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
       break;
 
     case BT_CHARACTER:
-      arg2 = se->string_length;
+      if (se->string_length)
+	arg2 = se->string_length;
+      else
+	{
+	  tmp = gfc_build_indirect_ref (addr_expr);
+	  gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+	  arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
+	}
       function = iocall_x_character;
       break;
 
     case BT_DERIVED:
+      /* Recurse into the elements of the derived type.  */
       expr = gfc_evaluate_now (addr_expr, &se->pre);
       expr = gfc_build_indirect_ref (expr);
 
@@ -1193,17 +1291,17 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
 	  tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
 			NULL_TREE);
 
-	  if (c->ts.type == BT_CHARACTER)
-	    {
-	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
-	      se->string_length =
-		TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
-	    }
-	  if (c->dimension)
-	    gfc_todo_error ("IO of arrays in derived types");
-	  if (!c->pointer)
-	    tmp = gfc_build_addr_expr (NULL, tmp);
-	  transfer_expr (se, &c->ts, tmp);
+          if (c->dimension)
+            {
+              tmp = transfer_array_component (tmp, c);
+              gfc_add_expr_to_block (&se->pre, tmp);
+            }
+          else
+            {
+              if (!c->pointer)
+                tmp = gfc_build_addr_expr (NULL, tmp);
+              transfer_expr (se, &c->ts, tmp);
+            }
 	}
       return;
 
@@ -1281,7 +1379,7 @@ gfc_trans_transfer (gfc_code * code)
 
   gfc_add_expr_to_block (&block, tmp);
 
-  return gfc_finish_block (&block);;
+  return gfc_finish_block (&block);
 }
 
 #include "gt-fortran-trans-io.h"

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2004-09-16  Victor Leikehman  <lei@il.ibm.com>
+
+	PR/15364
+	* gfortran.dg/der_array_io_1.f90: New test.
+	* gfortran.dg/der_array_io_2.f90: New test.
+	* gfortran.dg/der_array_io_3.f90: New test.
+
 2004-09-15  Mark Mitchell  <mark@codesourcery.com>
 
 	* testsuite/g++.old-deja/g++.abi/cxa_vec.C: Adjust for ARM

gcc/testsuite/gfortran.dg/der_array_io_1.f90

@@ -0,0 +1,24 @@
+! Test IO of arrays of integers in derived types
+! { dg-do run }
+program main
+
+  character* 10000 :: buf1, buf2
+  type xyz
+     integer :: x, y(3), z
+  end type xyz
+
+  type (xyz) :: foo(4)
+
+  do i=1,ubound(foo,1)
+     foo(i)%x = 100*i
+     do j=1,3
+        foo(i)%y(j) = 100*i + 10*j 
+     enddo
+     foo(i)%z = 100*i+40
+  enddo
+
+  print (buf1, '(20i4)'), foo
+  print (buf2, '(20i4)'), (foo(i)%x, (foo(i)%y(j), j=1,3), foo(i)%z, i=1,4)
+
+  if (buf1.ne.buf2) call abort
+end program main

gcc/testsuite/gfortran.dg/der_array_io_2.f90

@@ -0,0 +1,29 @@
+! Test IO of arrays in derived type arrays
+! { dg-do run }
+program main
+
+  character *1000 buf1, buf2
+
+  type :: foo_type                                             
+     integer x(3)
+     integer y(4)
+     integer z(5)
+     character*11 a(3)
+  end type foo_type
+                                                                        
+  type (foo_type) :: foo(2)
+  
+  foo(1)%x = 3
+  foo(1)%y = 4
+  foo(1)%z = 5
+  foo(1)%a = "hello world"
+
+  foo(2)%x = 30
+  foo(2)%y = 40
+  foo(2)%z = 50
+  foo(2)%a = "HELLO WORLD"
+
+  print (buf1,*), foo
+  print (buf2,*), ((foo(i)%x(j),j=1,3), (foo(i)%y(j),j=1,4), (foo(i)%z(j),j=1,5), (foo(i)%a(j),j=1,3), i=1,2)
+  if (buf1.ne.buf2) call abort
+end program main

gcc/testsuite/gfortran.dg/der_array_io_3.f90

@@ -0,0 +1,13 @@
+! Test IO of character arrays in derived types.
+! { dg-do run }
+program main
+ character*1000 buf1, buf2
+ type :: foo_type
+     character(12), dimension(13) :: name = "hello world "
+  end type foo_type
+  type (foo_type) :: foo
+!  foo = foo_type("hello world ")
+  print (buf1,*), foo
+  print (buf2,*), (foo%name(i), i=1,13)
+  if (buf1.ne.buf2) call abort
+end program main