[multiple changes]

2005-09-24  Janne Blomqvist  <jblomqvi@cc.hut.fi>

	* trans-io.c (gfc_build_io_library_fndecls): Add entry
	iocall_x_array for transfer_array. (transfer_array_desc): New
	function. (gfc_trans_transfer): Add code to call
	transfer_array_desc.

2005-09-24  Janne Blomqvist <jblomqvi@cc.hut.fi>

	* io.h: Changed prototypes of list_formatted_{read|write}.
	* list_read.c (list_formatted_read): Renamed to
	list_formatted_read_scalar and made static. (list_formatted_read):
	New function.
	* transfer.c: Prototype for transfer_array. Changed transfer
	function pointer. (unformatted_read): Add nelems argument, use
	it. (unformatted_write): Likewise. (formatted_transfer): Changed
	name to formatted_transfer_scalar. (formatted_transfer): New
	function. (transfer_integer): Add nelems argument to transfer
	call, move updating item count to transfer
	functions. (transfer_real): Likewise. (transfer_logical):
	Likewise. (transfer_character): Likewise. (transfer_complex):
	Likewise. (transfer_array): New function. (data_transfer_init):
	Call formatted_transfer with new argument. (iolength_transfer):
	New argument, use it.
	* write.c (list_formatted_write): Renamed to
	list_formatted_write_scalar, made static. (list_formatted_write):
	New function.

From-SVN: r104662

gcc/fortran/ChangeLog

+2005-09-24  Janne Blomqvist  <jblomqvi@cc.hut.fi>
+
+	* trans-io.c (gfc_build_io_library_fndecls): Add entry
+	iocall_x_array for transfer_array. (transfer_array_desc): New
+	function. (gfc_trans_transfer): Add code to call
+	transfer_array_desc.
+
 2005-09-26  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/23677

gcc/fortran/trans-io.c

@@ -120,6 +120,7 @@ static GTY(()) tree iocall_x_logical;
 static GTY(()) tree iocall_x_character;
 static GTY(()) tree iocall_x_real;
 static GTY(()) tree iocall_x_complex;
+static GTY(()) tree iocall_x_array;
 static GTY(()) tree iocall_open;
 static GTY(()) tree iocall_close;
 static GTY(()) tree iocall_inquire;
@@ -267,6 +268,12 @@ gfc_build_io_library_fndecls (void)
 				     void_type_node, 2, pvoid_type_node,
 				     gfc_int4_type_node);
 
+  iocall_x_array =
+    gfc_build_library_function_decl (get_identifier
+				     (PREFIX("transfer_array")),
+				     void_type_node, 2, pvoid_type_node,
+				     gfc_charlen_type_node);
+
   /* Library entry points */
 
   iocall_read =
@@ -1584,6 +1591,27 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
 }
 
 
+/* Generate a call to pass an array descriptor to the IO library. The
+   array should be of one of the intrinsic types.  */
+
+static void
+transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
+{
+  tree args, tmp, charlen_arg;
+
+  if (ts->type == BT_CHARACTER)
+    charlen_arg = se->string_length;
+  else
+    charlen_arg = build_int_cstu (NULL_TREE, 0);
+
+  args = gfc_chainon_list (NULL_TREE, addr_expr);
+  args = gfc_chainon_list (args, charlen_arg);
+  tmp = gfc_build_function_call (iocall_x_array, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+  gfc_add_block_to_block (&se->pre, &se->post);
+}
+
+
 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
 
 tree
@@ -1597,6 +1625,7 @@ gfc_trans_transfer (gfc_code * code)
   tree tmp;
 
   gfc_start_block (&block);
+  gfc_init_block (&body);
 
   expr = code->expr;
   ss = gfc_walk_expr (expr);
@@ -1604,8 +1633,11 @@ gfc_trans_transfer (gfc_code * code)
   gfc_init_se (&se, NULL);
 
   if (ss == gfc_ss_terminator)
-    gfc_init_block (&body);
-  else
+    {
+      gfc_conv_expr_reference (&se, expr);
+      transfer_expr (&se, &expr->ts, se.expr);
+    }
+  else if (expr->ts.type == BT_DERIVED)
     {
       /* Initialize the scalarizer.  */
       gfc_init_loopinfo (&loop);
@@ -1621,11 +1653,17 @@ gfc_trans_transfer (gfc_code * code)
 
       gfc_copy_loopinfo_to_se (&se, &loop);
       se.ss = ss;
-    }
-
-  gfc_conv_expr_reference (&se, expr);
 
-  transfer_expr (&se, &expr->ts, se.expr);
+      gfc_conv_expr_reference (&se, expr);
+      transfer_expr (&se, &expr->ts, se.expr);
+    }
+  else
+    {
+      /* Pass the array descriptor to the library.  */
+      gfc_conv_expr_descriptor (&se, expr, ss);
+      tmp = gfc_build_addr_expr (NULL, se.expr);
+      transfer_array_desc (&se, &expr->ts, tmp);
+    }
 
   gfc_add_block_to_block (&body, &se.pre);
   gfc_add_block_to_block (&body, &se.post);

libgfortran/ChangeLog

+2005-09-24  Janne Blomqvist <jblomqvi@cc.hut.fi>
+
+	* io.h: Changed prototypes of list_formatted_{read|write}.
+	* list_read.c (list_formatted_read): Renamed to
+	list_formatted_read_scalar and made static. (list_formatted_read):
+	New function.
+	* transfer.c: Prototype for transfer_array. Changed transfer
+	function pointer. (unformatted_read): Add nelems argument, use
+	it. (unformatted_write): Likewise. (formatted_transfer): Changed
+	name to formatted_transfer_scalar. (formatted_transfer): New
+	function. (transfer_integer): Add nelems argument to transfer
+	call, move updating item count to transfer
+	functions. (transfer_real): Likewise. (transfer_logical):
+	Likewise. (transfer_character): Likewise. (transfer_complex):
+	Likewise. (transfer_array): New function. (data_transfer_init):
+	Call formatted_transfer with new argument. (iolength_transfer):
+	New argument, use it.
+	* write.c (list_formatted_write): Renamed to
+	list_formatted_write_scalar, made static. (list_formatted_write):
+	New function.
+
 2005-09-26  David Edelsohn  <dje@watson.ibm.com>
 
 	* configure.ac: Add check for __clog.

libgfortran/io/io.h

@@ -613,7 +613,7 @@ internal_proto(read_decimal);
 
 /* list_read.c */
 
-extern void list_formatted_read (bt, void *, int);
+extern void list_formatted_read (bt, void *, int, size_t);
 internal_proto(list_formatted_read);
 
 extern void finish_list_read (void);
@@ -666,7 +666,7 @@ internal_proto(write_x);
 extern void write_z (fnode *, const char *, int);
 internal_proto(write_z);
 
-extern void list_formatted_write (bt, void *, int);
+extern void list_formatted_write (bt, void *, int, size_t);
 internal_proto(list_formatted_write);
 
 /* error.c */

libgfortran/io/list_read.c

@@ -1285,8 +1285,8 @@ check_type (bt type, int len)
    reading, usually in the value[] array.  If a repeat count is
    greater than one, we copy the data item multiple times.  */
 
-void
-list_formatted_read (bt type, void *p, int len)
+static void
+list_formatted_read_scalar (bt type, void *p, int len)
 {
   char c;
   int m;
@@ -1406,6 +1406,30 @@ list_formatted_read (bt type, void *p, int len)
     free_saved ();
 }
 
+
+void
+list_formatted_read  (bt type, void *p, int len, size_t nelems)
+{
+  size_t elem;
+  int size;
+  char *tmp;
+
+  tmp = (char *) p;
+
+  if (type == BT_COMPLEX)
+    size = 2 * len;
+  else
+    size = len;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      g.item_count++;
+      list_formatted_read_scalar (type, tmp + size*elem, len);
+    }
+}
+
+
 void
 init_at_eol(void)
 {

libgfortran/io/transfer.c

@@ -78,6 +78,9 @@ export_proto(transfer_character);
 extern void transfer_complex (void *, int);
 export_proto(transfer_complex);
 
+extern void transfer_array (gfc_array_char *, gfc_charlen_type);
+export_proto(transfer_array);
+
 gfc_unit *current_unit = NULL;
 static int sf_seen_eor = 0;
 static int eor_condition = 0;
@@ -101,7 +104,7 @@ static st_option advance_opt[] = {
 };
 
 
-static void (*transfer) (bt, void *, int);
+static void (*transfer) (bt, void *, int, size_t);
 
 
 typedef enum
@@ -312,11 +315,13 @@ write_block (int length)
 /* Master function for unformatted reads.  */
 
 static void
-unformatted_read (bt type, void *dest, int length)
+unformatted_read (bt type, void *dest, int length, size_t nelems)
 {
   void *source;
   int w;
 
+  length *= nelems;
+
   /* Transfer functions get passed the kind of the entity, so we have
      to fix this for COMPLEX data which are twice the size of their
      kind.  */
@@ -337,17 +342,20 @@ unformatted_read (bt type, void *dest, int length)
 /* Master function for unformatted writes.  */
 
 static void
-unformatted_write (bt type, void *source, int length)
+unformatted_write (bt type, void *source, int length, size_t nelems)
 {
   void *dest;
+  size_t len;
+
+  len = length * nelems;
 
   /* Correction for kind vs. length as in unformatted_read.  */
   if (type == BT_COMPLEX)
-    length *= 2;
+    len *= 2;
 
-  dest = write_block (length);
+  dest = write_block (len);
   if (dest != NULL)
-    memcpy (dest, source, length);
+    memcpy (dest, source, len);
 }
 
 
@@ -442,7 +450,7 @@ require_type (bt expected, bt actual, fnode * f)
    of the next element, then comes back here to process it.  */
 
 static void
-formatted_transfer (bt type, void *p, int len)
+formatted_transfer_scalar (bt type, void *p, int len)
 {
   int pos, bytes_used;
   fnode *f;
@@ -837,6 +845,29 @@ formatted_transfer (bt type, void *p, int len)
   unget_format (f);
 }
 
+static void
+formatted_transfer (bt type, void *p, int len, size_t nelems)
+{
+  size_t elem;
+  int  size;
+  char *tmp;
+
+  tmp = (char *) p;
+
+  if (type == BT_COMPLEX)
+    size = 2 * len;
+  else
+    size = len;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      g.item_count++;
+      formatted_transfer_scalar (type, tmp + size*elem, len);
+    }
+}
+
+
 
 /* Data transfer entry points.  The type of the data entity is
    implicit in the subroutine call.  This prevents us from having to
@@ -845,50 +876,153 @@ formatted_transfer (bt type, void *p, int len)
 void
 transfer_integer (void *p, int kind)
 {
-  g.item_count++;
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_INTEGER, p, kind);
+  transfer (BT_INTEGER, p, kind, 1);
 }
 
 
 void
 transfer_real (void *p, int kind)
 {
-  g.item_count++;
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_REAL, p, kind);
+  transfer (BT_REAL, p, kind, 1);
 }
 
 
 void
 transfer_logical (void *p, int kind)
 {
-  g.item_count++;
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_LOGICAL, p, kind);
+  transfer (BT_LOGICAL, p, kind, 1);
 }
 
 
 void
 transfer_character (void *p, int len)
 {
-  g.item_count++;
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_CHARACTER, p, len);
+  transfer (BT_CHARACTER, p, len, 1);
 }
 
 
 void
 transfer_complex (void *p, int kind)
 {
-  g.item_count++;
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_COMPLEX, p, kind);
+  transfer (BT_COMPLEX, p, kind, 1);
+}
+
+
+void
+transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
+{
+  index_type count[GFC_MAX_DIMENSIONS];
+  index_type extent[GFC_MAX_DIMENSIONS];
+  index_type stride[GFC_MAX_DIMENSIONS];
+  index_type stride0, rank, size, type, n, kind;
+  size_t tsize;
+  char *data;
+  bt iotype;
+
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+  type = GFC_DESCRIPTOR_TYPE (desc);
+  size = GFC_DESCRIPTOR_SIZE (desc);
+  kind = size;
+
+  /* FIXME: What a kludge: Array descriptors and the IO library use
+     different enums for types.  */
+  switch (type)
+    {
+    case GFC_DTYPE_UNKNOWN:
+      iotype = BT_NULL;  /* Is this correct?  */
+      break;
+    case GFC_DTYPE_INTEGER:
+      iotype = BT_INTEGER;
+      break;
+    case GFC_DTYPE_LOGICAL:
+      iotype = BT_LOGICAL;
+      break;
+    case GFC_DTYPE_REAL:
+      iotype = BT_REAL;
+      break;
+    case GFC_DTYPE_COMPLEX:
+      iotype = BT_COMPLEX;
+      kind /= 2;
+      break;
+    case GFC_DTYPE_CHARACTER:
+      iotype = BT_CHARACTER;
+      /* FIXME: Currently dtype contains the charlen, which is
+	 clobbered if charlen > 2**24. That's why we use a separate
+	 argument for the charlen. However, if we want to support
+	 non-8-bit charsets we need to fix dtype to contain
+	 sizeof(chartype) and fix the code below.  */
+      size = charlen;
+      kind = charlen;
+      break;
+    case GFC_DTYPE_DERIVED:
+      internal_error ("Derived type I/O should have been handled via the frontend.");
+      break;
+    default:
+      internal_error ("transfer_array(): Bad type");
+    }
+
+  if (desc->dim[0].stride == 0)
+    desc->dim[0].stride = 1;
+
+  rank = GFC_DESCRIPTOR_RANK (desc);
+  for (n = 0; n < rank; n++)
+    {
+      count[n] = 0;
+      stride[n] = desc->dim[n].stride;
+      extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
+
+      /* If the extent of even one dimension is zero, then the entire
+	 array section contains zero elements, so we return.  */
+      if (extent[n] == 0)
+	return;
+    }
+
+  stride0 = stride[0];
+
+  /* If the innermost dimension has stride 1, we can do the transfer
+     in contiguous chunks.  */
+  if (stride0 == 1)
+    tsize = extent[0];
+  else
+    tsize = 1;
+
+  data = GFC_DESCRIPTOR_DATA (desc);
+
+  while (data)
+    {
+      transfer (iotype, data, kind, tsize);
+      data += stride0 * size * tsize;
+      count[0] += tsize;
+      n = 0;
+      while (count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  data -= stride[n] * extent[n] * size;
+	  n++;
+	  if (n == rank)
+	    {
+	      data = NULL;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      data += stride[n] * size;
+	    }
+	}
+    }
 }
 
 
@@ -1245,7 +1379,7 @@ data_transfer_init (int read_flag)
   /* Start the data transfer if we are doing a formatted transfer.  */
   if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
       && ioparm.namelist_name == NULL && ionml == NULL)
-    formatted_transfer (0, NULL, 0);
+    formatted_transfer (0, NULL, 0, 1);
 }
 
 
@@ -1568,15 +1702,15 @@ finalize_transfer (void)
    data transfer, it just updates the length counter.  */
 
 static void
-iolength_transfer (bt type , void *dest __attribute__ ((unused)),
-		   int len)
+iolength_transfer (bt type, void *dest __attribute__ ((unused)),
+		   int len, size_t nelems)
 {
   if (ioparm.iolength != NULL)
     {
       if (type == BT_COMPLEX)
-	*ioparm.iolength += 2*len;
+	*ioparm.iolength += 2 * len * nelems;
       else
-	*ioparm.iolength += len;
+	*ioparm.iolength += len * nelems;
     }
 }
 

libgfortran/io/write.c

@@ -1423,8 +1423,8 @@ write_separator (void)
    TODO: handle skipping to the next record correctly, particularly
    with strings.  */
 
-void
-list_formatted_write (bt type, void *p, int len)
+static void
+list_formatted_write_scalar (bt type, void *p, int len)
 {
   static int char_flag;
 
@@ -1468,6 +1468,29 @@ list_formatted_write (bt type, void *p, int len)
   char_flag = (type == BT_CHARACTER);
 }
 
+
+void
+list_formatted_write (bt type, void *p, int len, size_t nelems)
+{
+  size_t elem;
+  int size;
+  char *tmp;
+
+  tmp = (char *) p;
+
+  if (type == BT_COMPLEX)
+    size = 2 * len;
+  else
+    size = len;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      g.item_count++;
+      list_formatted_write_scalar (type, tmp + size*elem, len);
+    }
+}
+
 /*			NAMELIST OUTPUT
 
    nml_write_obj writes a namelist object to the output stream.  It is called