PR fortran/21875 Internal Unit Array I/O, NIST

2005-09-14  Jerry DeLisle  <jvdelisle@verizon.net

	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.

From-SVN: r104276

libgfortran/ChangeLog

@@ -1,3 +1,27 @@
+2005-09-14  Jerry DeLisle  <jvdelisle@verizon.net
+
+	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.
+
 2005-09-13  Richard Sandiford  <richard@codesourcery.com>
 
 	PR target/19269

libgfortran/io/io.h

@@ -251,6 +251,7 @@ typedef struct
   CHARACTER (advance);
   CHARACTER (name);
   CHARACTER (internal_unit);
+  gfc_array_char *internal_unit_desc;
   CHARACTER (sequential);
   CHARACTER (direct);
   CHARACTER (formatted);
@@ -525,6 +526,12 @@ internal_proto(close_unit);
 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);
 

libgfortran/io/transfer.c

@@ -292,14 +292,14 @@ void *
 write_block (int length)
 {
   char *dest;
-
-  if (!is_internal_unit() && current_unit->bytes_left < length)
+  
+  if (current_unit->bytes_left < length)
     {
       generate_error (ERROR_EOR, NULL);
       return NULL;
     }
 
-  current_unit->bytes_left -= length;
+  current_unit->bytes_left -= (gfc_offset)length;
   dest = salloc_w (current_unit->s, &length);
 
   if (ioparm.size != NULL)
@@ -1021,15 +1021,6 @@ data_transfer_init (int read_flag)
   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)
@@ -1267,7 +1258,7 @@ data_transfer_init (int read_flag)
 static void
 next_record_r (void)
 {
-  int rlength, length;
+  int rlength, length, bytes_left;
   gfc_offset new;
   char *p;
 
@@ -1321,16 +1312,18 @@ next_record_r (void)
 	  break;
 	}
 
-      do
+      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);
 
-	  /* 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);
@@ -1359,7 +1352,7 @@ static void
 next_record_w (void)
 {
   gfc_offset c, m;
-  int length;
+  int length, bytes_left;
   char *p;
 
   /* Zero counters for X- and T-editing.  */
@@ -1422,15 +1415,36 @@ next_record_w (void)
       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 (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
@@ -1444,9 +1458,6 @@ next_record_w (void)
 	    goto io_error;
 	}
 
-      if (sfree (current_unit->s) == FAILURE)
-	goto io_error;
-
       break;
 
     io_error:

libgfortran/io/unit.c

@@ -244,6 +244,32 @@ find_unit (int n)
   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;
+      record_count *= desc->dim[i].ubound;
+    }
+  return record_count;
+}
+
+ 
 /* get_unit()-- Returns the unit structure associated with the integer
  * unit or the internal file. */
 
@@ -252,8 +278,18 @@ get_unit (int read_flag __attribute__ ((unused)))
 {
   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 */
 
@@ -271,8 +307,7 @@ get_unit (int read_flag __attribute__ ((unused)))
 }
 
 
-/* is_internal_unit()-- Determine if the current unit is internal or
- * not */
+/* is_internal_unit()-- Determine if the current unit is internal or not */
 
 int
 is_internal_unit (void)
@@ -281,6 +316,14 @@ is_internal_unit (void)
 }
 
 
+/* 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 */

libgfortran/io/unix.c

@@ -38,6 +38,7 @@ Boston, MA 02110-1301, USA.  */
 #include <stdio.h>
 #include <sys/stat.h>
 #include <fcntl.h>
+#include <assert.h>
 
 #ifdef HAVE_SYS_MMAN_H
 #include <sys/mman.h>
@@ -618,14 +619,22 @@ mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
 {
   gfc_offset m;
 
+  assert (*len >= 0);  /* Negative values not allowed. */
+  
   if (where == -1)
     where = s->logical_offset;
 
   m = where + *len;
 
-  if (where < s->buffer_offset || m > s->buffer_offset + s->active)
+  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);

libgfortran/libgfortran.h

@@ -344,6 +344,7 @@ typedef enum
   ERROR_BAD_US,
   ERROR_READ_VALUE,
   ERROR_READ_OVERFLOW,
+  ERROR_ARRAY_STRIDE,
   ERROR_LAST			/* Not a real error, the last error # + 1.  */
 }
 error_codes;

libgfortran/runtime/error.c

@@ -431,6 +431,10 @@ translate_error (int code)
       p = "Numeric overflow on read";
       break;
 
+    case ERROR_ARRAY_STRIDE:
+      p = "Array unit stride must be 1";
+      break;
+
     default:
       p = "Unknown error code";
       break;