Re: [patch,fix, PING] PR21875 Internal Array IO and NIST final fix

[Jerry DeLisle <jvdelisle at verizon dot net>]

Attached is revised patch for internal unit array I/O

This revision affects only the frontend patches which are attached with new test 
cases.

(
See http://gcc.gnu.org/ml/fortran/2005-09/msg00176.html for frontend patch to 
trans-io.c
)

Significant changes relate to checking for contiguous array sections and adding 
error messages for bad arrays and end of file condition.

I would like to request we try to get this into 4.0.2 since it resolves 
significant deficiencies in NIST, and other test suites.

Regression tested OK, NIST tested OK

OK for 4.1?  4.0.2 if approved by Mark?

Best regards,

Jerry

	PR fortran/21875 Internal Unit Array I/O, NIST
	* libgfortran.h: Add run time error code for array stride.
	* runtime/error.c (translate_error): Add error message for
	array stride.
	* io/io.h: Add array descriptor pointer to IOPARM structure.
	Add prtotypes for two new functions.
	* io/transfer.c (data_transfer_init): Removed initialization and
	moved to unit.c (get_unit)
	* io/transfer.c (next_record_r): Include internal unit read
	functionality.
	* io/transfer.c (next_record_w): Include internal unit write
	functionality, including padding of character array records.
	* io/unit.c (get_array_unit_len): New function to return the number
	of records in the character array 'file' from the array descriptor.
	* io/unit.c (get_unit): Gathered initialization code from
	init_data_transfer for internal units and added initialization of
	character array unit.
	* io/unit.c (is_array_io): New function to determine if internal unit
	is an array.
	* io/unix.c (mem_alloc_w_at): Add error checks for bad record length
	and end of file.

Index: libgfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/libgfortran.h,v
retrieving revision 1.31
diff -c -3 -p -r1.31 libgfortran.h
*** libgfortran.h	2 Sep 2005 13:29:50 -0000	1.31
--- libgfortran.h	13 Sep 2005 19:45:15 -0000
*************** typedef enum
*** 344,349 ****
--- 344,350 ----
    ERROR_BAD_US,
    ERROR_READ_VALUE,
    ERROR_READ_OVERFLOW,
+   ERROR_ARRAY_STRIDE,
    ERROR_LAST			/* Not a real error, the last error # + 1.  */
  }
  error_codes;
Index: io/io.h
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/io.h,v
retrieving revision 1.30
diff -c -3 -p -r1.30 io.h
*** io/io.h	11 Sep 2005 13:34:57 -0000	1.30
--- io/io.h	13 Sep 2005 19:45:15 -0000
*************** typedef struct
*** 251,256 ****
--- 251,257 ----
    CHARACTER (advance);
    CHARACTER (name);
    CHARACTER (internal_unit);
+   gfc_array_char *internal_unit_desc;
    CHARACTER (sequential);
    CHARACTER (direct);
    CHARACTER (formatted);
*************** internal_proto(close_unit);
*** 525,530 ****
--- 526,537 ----
  extern int is_internal_unit (void);
  internal_proto(is_internal_unit);
  
+ extern int is_array_io (void);
+ internal_proto(is_array_io);
+ 
+ extern gfc_offset get_array_unit_len (gfc_array_char *);
+ internal_proto(get_array_unit_len);
+ 
  extern gfc_unit *find_unit (int);
  internal_proto(find_unit);
  
Index: io/transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.58
diff -c -3 -p -r1.58 transfer.c
*** io/transfer.c	11 Sep 2005 13:34:57 -0000	1.58
--- io/transfer.c	13 Sep 2005 19:45:15 -0000
*************** void *
*** 292,305 ****
  write_block (int length)
  {
    char *dest;
! 
!   if (!is_internal_unit() && current_unit->bytes_left < length)
      {
        generate_error (ERROR_EOR, NULL);
        return NULL;
      }
  
!   current_unit->bytes_left -= length;
    dest = salloc_w (current_unit->s, &length);
  
    if (ioparm.size != NULL)
--- 292,305 ----
  write_block (int length)
  {
    char *dest;
!   
!   if (current_unit->bytes_left < length)
      {
        generate_error (ERROR_EOR, NULL);
        return NULL;
      }
  
!   current_unit->bytes_left -= (gfc_offset)length;
    dest = salloc_w (current_unit->s, &length);
  
    if (ioparm.size != NULL)
*************** data_transfer_init (int read_flag)
*** 1021,1035 ****
    if (current_unit == NULL)
      return;
  
-   if (is_internal_unit())
-     {
-       current_unit->recl = file_length(current_unit->s);
-       if (g.mode==WRITING)
-         empty_internal_buffer (current_unit->s);
-       else
-         current_unit->bytes_left = current_unit->recl;	
-     }
- 
    /* Check the action.  */
  
    if (read_flag && current_unit->flags.action == ACTION_WRITE)
--- 1021,1026 ----
*************** data_transfer_init (int read_flag)
*** 1267,1273 ****
  static void
  next_record_r (void)
  {
!   int rlength, length;
    gfc_offset new;
    char *p;
  
--- 1258,1264 ----
  static void
  next_record_r (void)
  {
!   int rlength, length, bytes_left;
    gfc_offset new;
    char *p;
  
*************** next_record_r (void)
*** 1321,1336 ****
  	  break;
  	}
  
!       do
  	{
  	  p = salloc_r (current_unit->s, &length);
  
- 	  /* In case of internal file, there may not be any '\n'.  */
- 	  if (is_internal_unit() && p == NULL)
- 	    {
- 	       break;
- 	    }
- 
  	  if (p == NULL)
  	    {
  	      generate_error (ERROR_OS, NULL);
--- 1312,1329 ----
  	  break;
  	}
  
!       if (is_internal_unit())
! 	{
! 	  bytes_left = (int)current_unit->bytes_left;
! 	  p = salloc_r (current_unit->s, &bytes_left);
! 	  if (p != NULL)
! 	    current_unit->bytes_left = current_unit->recl;
! 	  break;
! 	}
!       else do
  	{
  	  p = salloc_r (current_unit->s, &length);
  
  	  if (p == NULL)
  	    {
  	      generate_error (ERROR_OS, NULL);
*************** static void
*** 1359,1365 ****
  next_record_w (void)
  {
    gfc_offset c, m;
!   int length;
    char *p;
  
    /* Zero counters for X- and T-editing.  */
--- 1352,1358 ----
  next_record_w (void)
  {
    gfc_offset c, m;
!   int length, bytes_left;
    char *p;
  
    /* Zero counters for X- and T-editing.  */
*************** next_record_w (void)
*** 1422,1436 ****
        break;
  
      case FORMATTED_SEQUENTIAL:
  #ifdef HAVE_CRLF
!       length = 2;
  #else
!       length = 1;
  #endif
!       p = salloc_w (current_unit->s, &length);
! 
!       if (!is_internal_unit())
! 	{
  	  if (p)
  	    {  /* No new line for internal writes.  */
  #ifdef HAVE_CRLF
--- 1415,1450 ----
        break;
  
      case FORMATTED_SEQUENTIAL:
+ 
+       if (current_unit->bytes_left == 0)
+ 	break;
+ 	
+       if (is_internal_unit())
+ 	{
+ 	  if (is_array_io())
+ 	    {
+ 	      bytes_left = (int)current_unit->bytes_left;
+ 	      p = salloc_w (current_unit->s, &bytes_left);
+ 	      if (p != NULL)
+ 		{
+ 		  memset(p, ' ', bytes_left);
+ 	          current_unit->bytes_left = current_unit->recl;
+ 		}
+ 	    }
+ 	  else
+ 	    {
+ 	      length = 1;
+ 	      p = salloc_w (current_unit->s, &length);
+ 	    }
+  	}
+       else
+ 	{
  #ifdef HAVE_CRLF
! 	  length = 2;
  #else
! 	  length = 1;
  #endif
! 	  p = salloc_w (current_unit->s, &length);
  	  if (p)
  	    {  /* No new line for internal writes.  */
  #ifdef HAVE_CRLF
*************** next_record_w (void)
*** 1444,1452 ****
  	    goto io_error;
  	}
  
-       if (sfree (current_unit->s) == FAILURE)
- 	goto io_error;
- 
        break;
  
      io_error:
--- 1458,1463 ----
Index: io/unit.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/unit.c,v
retrieving revision 1.14
diff -c -3 -p -r1.14 unit.c
*** io/unit.c	17 Aug 2005 02:49:01 -0000	1.14
--- io/unit.c	13 Sep 2005 19:45:15 -0000
*************** find_unit (int n)
*** 244,249 ****
--- 244,275 ----
    return p;
  }
  
+ 
+ /* get_array_unit_len()-- return the number of records in the array. */
+ 
+ gfc_offset
+ get_array_unit_len (gfc_array_char *desc)
+ {
+   gfc_offset record_count;
+   int i, rank, stride;
+   rank = GFC_DESCRIPTOR_RANK(desc);
+   record_count = stride = 1;
+   for (i=0;i<rank;++i)
+   {
+     /* Check that array is contiguous */
+ 
+     if (desc->dim[i].stride != stride)
+       {
+         generate_error (ERROR_ARRAY_STRIDE, NULL);
+         return NULL;
+       }
+     stride = desc->dim[i].ubound * stride;
+     record_count *= desc->dim[i].ubound;
+   }
+   return record_count;
+ }
+ 
+  
  /* get_unit()-- Returns the unit structure associated with the integer
   * unit or the internal file. */
  
*************** get_unit (int read_flag __attribute__ ((
*** 252,259 ****
--- 278,295 ----
  {
    if (ioparm.internal_unit != NULL)
      {
+       internal_unit.recl = ioparm.internal_unit_len;
+       if (is_array_io()) ioparm.internal_unit_len *=
+ 			   get_array_unit_len(ioparm.internal_unit_desc);
        internal_unit.s =
  	open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
+       internal_unit.bytes_left = internal_unit.recl;
+       internal_unit.last_record=0;
+       internal_unit.maxrec=0;
+       internal_unit.current_record=0;
+ 
+       if (g.mode==WRITING && !is_array_io())
+         empty_internal_buffer (internal_unit.s);
  
        /* Set flags for the internal unit */
  
*************** get_unit (int read_flag __attribute__ ((
*** 271,278 ****
  }
  
  
! /* is_internal_unit()-- Determine if the current unit is internal or
!  * not */
  
  int
  is_internal_unit (void)
--- 307,313 ----
  }
  
  
! /* is_internal_unit()-- Determine if the current unit is internal or not */
  
  int
  is_internal_unit (void)
*************** is_internal_unit (void)
*** 281,286 ****
--- 316,329 ----
  }
  
  
+ /* is_array_io ()-- Determine if the I/O is to/from an array */
+ 
+ int
+ is_array_io (void)
+ {
+   return (ioparm.internal_unit_desc != NULL);
+ }
+ 
  
  /*************************/
  /* Initialize everything */
Index: io/unix.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/unix.c,v
retrieving revision 1.39
diff -c -3 -p -r1.39 unix.c
*** io/unix.c	11 Sep 2005 13:34:57 -0000	1.39
--- io/unix.c	13 Sep 2005 19:45:16 -0000
*************** mem_alloc_w_at (unix_stream * s, int *le
*** 618,631 ****
  {
    gfc_offset m;
  
    if (where == -1)
      where = s->logical_offset;
  
    m = where + *len;
  
!   if (where < s->buffer_offset || m > s->buffer_offset + s->active)
      return NULL;
  
    s->logical_offset = m;
  
    return s->buffer + (where - s->buffer_offset);
--- 618,640 ----
  {
    gfc_offset m;
  
+   if (*len < 0)  /* This should never happen */
+     *len = 0;
+ 
    if (where == -1)
      where = s->logical_offset;
  
    m = where + *len;
  
!   if (where < s->buffer_offset)
      return NULL;
  
+   if (m > s->file_length)
+     {
+        generate_error (ERROR_END, NULL);
+        return NULL;
+     }
+ 
    s->logical_offset = m;
  
    return s->buffer + (where - s->buffer_offset);
Index: runtime/error.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/runtime/error.c,v
retrieving revision 1.14
diff -c -3 -p -r1.14 error.c
*** runtime/error.c	9 Sep 2005 18:21:37 -0000	1.14
--- runtime/error.c	13 Sep 2005 19:45:16 -0000
*************** translate_error (int code)
*** 431,436 ****
--- 431,440 ----
        p = "Numeric overflow on read";
        break;
  
+     case ERROR_ARRAY_STRIDE:
+       p = "Array unit stride must be 1";
+       break;
+ 
      default:
        p = "Unknown error code";
        break;

Attachment: arrayio_1.f90
Description: application/extension-f90

Attachment: arrayio_2.f90
Description: application/extension-f90

Attachment: arrayio_3.f90
Description: application/extension-f90

Attachment: arrayio_4.f90
Description: application/extension-f90

Attachment: arrayio_5.f90
Description: application/extension-f90