[patch, libgfortran] PR37077 Implement Internal Unit I/O for character KIND=4, Part 2

[patch, libgfortran] PR37077 Implement Internal Unit I/O for character KIND=4, Part 2

[Jerry DeLisle]

[-- Attachment #1: Type: text/plain, Size: 1329 bytes --]

Hi folks,

This patch adds READ support for wide character internal units.  It also takes 
care of the issue noted in comment #7 of the PR.

Regression tested on x86-64-linux-gnu. Test case attached. I will start looking 
at the ppc issue after I get this committed. I also plan to look over list 
directed read next.

OK for trunk?

Regards,

Jerry

2010-07-15  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.

[-- Attachment #2: read-iunit4-c.diff --]
[-- Type: text/x-patch, Size: 8099 bytes --]

Index: read.c
===================================================================
--- read.c	(revision 162238)
+++ read.c	(working copy)
@@ -383,26 +383,51 @@ read_utf8_char4 (st_parameter_dt *dtp, void *p, in
 static void
 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 {
-  char *s;
+  int m, n;
   gfc_char4_t *dest;
-  int m, n;
 
-  s = read_block_form (dtp, &width);
-  
-  if (s == NULL)
-    return;
-  if (width > len)
-     s += (width - len);
+  if (is_char4_unit(dtp))
+    {
+      gfc_char4_t *s4;
 
-  m = ((int) width > len) ? len : (int) width;
-  
-  dest = (gfc_char4_t *) p;
-  
-  for (n = 0; n < m; n++, dest++, s++)
-    *dest = (unsigned char ) *s;
+      s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
 
-  for (n = 0; n < len - (int) width; n++, dest++)
-    *dest = (unsigned char) ' ';
+      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);
+
+      if (s == NULL)
+	return;
+      if (width > len)
+	 s += (width - len);
+
+      m = ((int) width > len) ? len : (int) width;
+
+      dest = (gfc_char4_t *) p;
+
+      for (n = 0; n < m; n++, dest++, s++)
+	*dest = (unsigned char ) *s;
+
+      for (n = 0; n < len - (int) width; n++, dest++)
+	*dest = (unsigned char) ' ';
+    }
 }
 
 
Index: io.h
===================================================================
--- io.h	(revision 162238)
+++ io.h	(working copy)
@@ -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);
 
Index: unit.c
===================================================================
--- unit.c	(revision 162238)
+++ unit.c	(working copy)
@@ -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);
+    {
+      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.  */
 
Index: transfer.c
===================================================================
--- transfer.c	(revision 162238)
+++ transfer.c	(working copy)
@@ -202,7 +202,17 @@ read_sf_internal (st_parameter_dt *dtp, int * leng
     }
 
   lorig = *length;
-  base = mem_alloc_r (dtp->u.p.current_unit->s, 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))
     {
@@ -430,7 +440,7 @@ read_block_form (st_parameter_dt *dtp, int * nbyte
     dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
 
   if (norig != *nbytes)
-    {				
+    {
       /* Short read, this shouldn't happen.  */
       if (!dtp->u.p.current_unit->pad_status == PAD_YES)
 	{
@@ -445,6 +455,52 @@ read_block_form (st_parameter_dt *dtp, int * nbyte
 }
 
 
+/* 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
       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);
@@ -658,10 +713,10 @@ write_block (st_parameter_dt *dtp, int length)
     {
       dest = fbuf_alloc (dtp->u.p.current_unit, length);
       if (dest == NULL)
-        {
-          generate_error (&dtp->common, LIBERROR_OS, NULL);
-          return NULL;
-        }
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return NULL;
+	}
     }
     
   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
@@ -1258,7 +1313,7 @@ formatted_transfer_scalar_read (st_parameter_dt *d
 	  consume_data_flag = 0;
 	  dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
 	  break;
-	
+
 	case FMT_RC:
 	  consume_data_flag = 0;
 	  dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
@@ -1539,7 +1594,7 @@ formatted_transfer_scalar_write (st_parameter_dt *
 		write_i (dtp, f, p, kind);
 		break;
 	      case BT_LOGICAL:
-		write_l (dtp, f, p, kind);	
+		write_l (dtp, f, p, kind);
 		break;
 	      case BT_CHARACTER:
 		if (kind == 4)
Index: write.c
===================================================================
--- write.c	(revision 162238)
+++ write.c	(working copy)
@@ -1340,6 +1340,29 @@ write_character (st_parameter_dt *dtp, const char
       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

[-- Attachment #3: char4_iunit_2.f03 --]
[-- Type: text/plain, Size: 1865 bytes --]

! { dg-do run }
! PR37077 Implement Internal Unit I/O for character KIND=4
! Test case prepared by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
program char4_iunit_2
  implicit none
  integer, parameter :: k = 4
  character(kind=4,len=80) :: widestring, str_char4
  character(kind=1,len=80) :: skinnystring
  integer :: i,j
  real :: x
  character(9) :: str_default

  widestring = k_"12345 2.54360 hijklmnop qwertyuiopasdfg"
  skinnystring = "12345 2.54360 hijklmnop qwertyuiopasdfg"
  i = 77777
  x = 0.0
  str_default = "xxxxxxxxx"
  str_char4 = k_"xyzzy"
  read(widestring,'(i5,1x,f7.5,1x,a9,1x,a15)') i, x, str_default, str_char4
  if (i /= 12345 .or. (x - 2.5436001) > epsilon(x) .or. &
      str_default /= "hijklmnop" .or. str_char4 /= k_"qwertyuiopasdfg")&
      call abort
  i = 77777
  x = 0.0
  str_default = "xxxxxxxxx"
  str_char4 = k_"xyzzy"
  read(widestring,'(2x,i4,tl3,1x,f7.5,1x,a9,1x,a15)')i, x, str_default,&
       str_char4
  if (i /= 345 .or. (x - 52.542999) > epsilon(x) .or. &
      str_default /= "0 hijklmn" .or. str_char4 /= k_"p qwertyuiopasd")&
      call abort
  read(skinnystring,'(2x,i4,tl3,1x,f7.5,1x,a9,1x,a15)')i, x, str_default,&
   str_char4
  if (i /= 345 .or. (x - 52.542999) > epsilon(x) .or. &
      str_default /= "0 hijklmn" .or. str_char4 /= k_"p qwertyuiopasd")&
      call abort
  write(widestring,'(2x,i4,tl3,1x,f10.5,1x,a9,1x,a15)')i, x, str_default,&
   trim(str_char4)
  if (widestring .ne. k_"   3  52.54300 0 hijklmn p qwertyuiopasd") call abort
  write(skinnystring,'(2x,i4,tl3,1x,f10.5,1x,a9,1x,a15)')i, x, str_default,&
   trim(str_char4)
  if (skinnystring .ne. "   3  52.54300 0 hijklmn p qwertyuiopasd") call abort
  write(widestring,*)"test",i, x, str_default,&
   trim(str_char4)
  if (widestring .ne. &
    k_" test         345   52.542999     0 hijklmnp qwertyuiopasd") call abort
end program char4_iunit_2

Re: [patch, libgfortran] PR37077 Implement Internal Unit I/O for character KIND=4, Part 2

[Tobias Burnus]

On 07/16/2010 08:30 AM, Jerry DeLisle wrote:
> This patch adds READ support for wide character internal units.  It
> also takes care of the issue noted in comment #7 of the PR.
>
> Regression tested on x86-64-linux-gnu. Test case attached. I will
> start looking at the ppc issue after I get this committed. I also plan
> to look over list directed read next.
>
> OK for trunk?

In write_character, the new code has lots of tailing spaces (in the
otherwise empty lines). And one after "code borrowed from".

Otherwise, the code looks fine. Thanks!

Tobias

Re: [patch, libgfortran] PR37077 Implement Internal Unit I/O for character KIND=4, Part 2

[Jerry DeLisle]

On 07/16/2010 12:54 AM, Tobias Burnus wrote:
> On 07/16/2010 08:30 AM, Jerry DeLisle wrote:
>> This patch adds READ support for wide character internal units.  It
>> also takes care of the issue noted in comment #7 of the PR.
>>
>> Regression tested on x86-64-linux-gnu. Test case attached. I will
>> start looking at the ppc issue after I get this committed. I also plan
>> to look over list directed read next.
>>
>> OK for trunk?
>
> In write_character, the new code has lots of tailing spaces (in the
> otherwise empty lines). And one after "code borrowed from".
>
> Otherwise, the code looks fine. Thanks!
>
> Tobias
>

Cleaned up and committed as revision 162260.

Thanks for review.

Jerry