re PR fortran/37077 (Implement Internal Unit I/O for character KIND=4)

2010-07-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/37077
	* io/read.c (read_default_char4): Add support for reading into a
	kind-4 character variable from a character(kind=4) internal unit.
	* io/io.h (read_block_form4): Add prototype.
	* io/unit.c (get_internal_unit): Add call to fbuf_init.
	(free_internal_unit): Add call to fbuf_destroy. (get_unit): Fix
	whitespace.
	* io/transfer.c (read_sf_internal): Use fbuf_alloc to allocate a string
	to recieve the wide characters translated to single byte chracters.
	(read_block_form): Fix whitespace. (read_block_form4): New function to
	read from a character(kind=4) internal unit into a character(kind=4)
	variable. (read_block_direct): Fix whitespace. (write_block): Fix
	whitespace. (formatted_transfer_scalar_read): Likewise.
	(formatted_transfer_scalar_write): Likewise.
	* io/write.c (write_character): Add support for list directed write of
	a kind=1 character string to a character(kind=4) internal unit.

From-SVN: r162260

libgfortran/ChangeLog

+2010-07-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libfortran/37077
+	* io/read.c (read_default_char4): Add support for reading into a
+	kind-4 character variable from a character(kind=4) internal unit.
+	* io/io.h (read_block_form4): Add prototype.
+	* io/unit.c (get_internal_unit): Add call to fbuf_init.
+	(free_internal_unit): Add call to fbuf_destroy. (get_unit): Fix
+	whitespace.
+	* io/transfer.c (read_sf_internal): Use fbuf_alloc to allocate a string
+	to recieve the wide characters translated to single byte chracters.
+	(read_block_form): Fix whitespace. (read_block_form4): New function to
+	read from a character(kind=4) internal unit into a character(kind=4)
+	variable. (read_block_direct): Fix whitespace. (write_block): Fix
+	whitespace. (formatted_transfer_scalar_read): Likewise.
+	(formatted_transfer_scalar_write): Likewise.
+	* io/write.c (write_character): Add support for list directed write of
+	a kind=1 character string to a character(kind=4) internal unit.
+
 2010-07-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libfortran/44934

libgfortran/io/io.h

@@ -644,6 +644,9 @@ internal_proto(type_name);
 extern void * read_block_form (st_parameter_dt *, int *);
 internal_proto(read_block_form);
 
+extern void * read_block_form4 (st_parameter_dt *, int *);
+internal_proto(read_block_form4);
+
 extern void *write_block (st_parameter_dt *, int);
 internal_proto(write_block);
 

libgfortran/io/read.c

@@ -383,9 +383,33 @@ read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
 static void
 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 {
-  char *s;
-  gfc_char4_t *dest;
   int m, n;
+  gfc_char4_t *dest;
+
+  if (is_char4_unit(dtp))
+    {
+      gfc_char4_t *s4;
+
+      s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
+
+      if (s4 == NULL)
+	return;
+      if (width > len)
+	 s4 += (width - len);
+
+      m = ((int) width > len) ? len : (int) width;
+
+      dest = (gfc_char4_t *) p;
+
+      for (n = 0; n < m; n++)
+	*dest++ = *s4++;
+
+      for (n = 0; n < len - (int) width; n++)
+	*dest++ = (gfc_char4_t) ' ';
+    }
+  else
+    {
+      char *s;
 
       s = read_block_form (dtp, &width);
 
@@ -403,6 +427,7 @@ read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 
       for (n = 0; n < len - (int) width; n++, dest++)
 	*dest = (unsigned char) ' ';
+    }
 }
 
 

libgfortran/io/transfer.c

@@ -202,6 +202,16 @@ read_sf_internal (st_parameter_dt *dtp, int * length)
     }
 
   lorig = *length;
+  if (is_char4_unit(dtp))
+    {
+      int i;
+      gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
+			length);
+      base = fbuf_alloc (dtp->u.p.current_unit, lorig);
+      for (i = 0; i < *length; i++, p++)
+	base[i] = *p > 255 ? '?' : (unsigned char) *p;
+    }
+  else
     base = mem_alloc_r (dtp->u.p.current_unit->s, length);
 
   if (unlikely (lorig > *length))
@@ -445,6 +455,52 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
 }
 
 
+/* Read a block from a character(kind=4) internal unit, to be transferred into
+   a character(kind=4) variable.  Note: Portions of this code borrowed from
+   read_sf_internal.  */
+void *
+read_block_form4 (st_parameter_dt *dtp, int * nbytes)
+{
+  static gfc_char4_t *empty_string[0];
+  gfc_char4_t *source;
+  int lorig;
+
+  if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+    *nbytes = dtp->u.p.current_unit->bytes_left;
+
+  /* Zero size array gives internal unit len of 0.  Nothing to read. */
+  if (dtp->internal_unit_len == 0
+      && dtp->u.p.current_unit->pad_status == PAD_NO)
+    hit_eof (dtp);
+
+  /* If we have seen an eor previously, return a length of 0.  The
+     caller is responsible for correctly padding the input field.  */
+  if (dtp->u.p.sf_seen_eor)
+    {
+      *nbytes = 0;
+      /* Just return something that isn't a NULL pointer, otherwise the
+         caller thinks an error occured.  */
+      return empty_string;
+    }
+
+  lorig = *nbytes;
+  source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes);
+
+  if (unlikely (lorig > *nbytes))
+    {
+      hit_eof (dtp);
+      return NULL;
+    }
+
+  dtp->u.p.current_unit->bytes_left -= *nbytes;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
+
+  return source;
+}
+
+
 /* Reads a block directly into application data space.  This is for
    unformatted files.  */
 
@@ -561,7 +617,6 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
       have_read_record += have_read_subrecord;
 
       if (unlikely (to_read_subrecord != have_read_subrecord))
-			
 	{
 	  /* Short read, e.g. if we hit EOF.  This means the record
 	     structure has been corrupted, or the trailing record
@@ -640,7 +695,7 @@ write_block (st_parameter_dt *dtp, int length)
 
   if (is_internal_unit (dtp))
     {
-      if (dtp->common.unit) /* char4 internal unit.  */
+      if (dtp->common.unit) /* char4 internel unit.  */
 	dest = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
       else
 	dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);

libgfortran/io/unit.c

@@ -424,8 +424,11 @@ get_internal_unit (st_parameter_dt *dtp)
 
   /* Set initial values for unit parameters.  */
   if (dtp->common.unit)
+    {
       iunit->s = open_internal4 (dtp->internal_unit - start_record,
 				 dtp->internal_unit_len, -start_record);
+      fbuf_init (iunit, 256);
+    }
   else
     iunit->s = open_internal (dtp->internal_unit - start_record,
 			      dtp->internal_unit_len, -start_record);
@@ -475,6 +478,9 @@ free_internal_unit (st_parameter_dt *dtp)
   if (!is_internal_unit (dtp))
     return;
 
+  if (unlikely (is_char4_unit (dtp)))
+    fbuf_destroy (dtp->u.p.current_unit);
+
   if (dtp->u.p.current_unit != NULL)
     {
       if (dtp->u.p.current_unit->ls != NULL)
@@ -497,7 +503,7 @@ get_unit (st_parameter_dt *dtp, int do_create)
 {
 
   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
-    return get_internal_unit(dtp);
+    return get_internal_unit (dtp);
 
   /* Has to be an external unit.  */
 

libgfortran/io/write.c

@@ -1340,6 +1340,29 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
       if (p == NULL)
 	return;
 
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t d4 = (gfc_char4_t) d;
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+
+	  if (d4 == ' ')
+	    memcpy4 (p4, 0, source, length);
+	  else
+	    {
+	      *p4++ = d4;
+
+	      for (i = 0; i < length; i++)
+		{
+		  *p4++ = (gfc_char4_t) source[i];
+		  if (source[i] == d)
+		    *p4++ = d4;
+		}
+
+	      *p4 = d4;
+	    }
+	  return;
+	}
+
       if (d == ' ')
 	memcpy (p, source, length);
       else