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

Submitted by Jerry DeLisle on July 16, 2010, 6:30 a.m.

Details

Message ID 4C3FFC9D.6050003@verizon.net
State New
Headers show

Commit Message

Jerry DeLisle July 16, 2010, 6:30 a.m.
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.
! { 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

Comments

Tobias Burnus July 16, 2010, 7:54 a.m.
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
Jerry DeLisle July 16, 2010, 2:21 p.m.
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

Patch hide | download patch | download mbox

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