re PR libfortran/20257 (Fortran runtime error: End of record occurs when writing large arrays)

2006-04-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/20257
	* io/io.h: Add prototypes for get_internal_unit and free_internal_unit.
	* io/unit.c (get_internal_unit): Initialize unit number, not zero.
	(free_internal_unit): New function to consolidate freeing memory.
	(get_unit): Initialize internal_unit_desc to NULL when unit is
	external.
	* io/unix.c (mem_close): Check for not NULL before freeing memory.
	* io/transfer.c (read_block): Reset bytes_left and skip error if unit
	is preconnected and default record length is reached.
	(read_block_direct): Ditto.
	(write_block): Ditto.
	(write_buf): Ditto.
	(data_transfer_init): Only flush if not internal unit.
	(finalize_transfer): Ditto and delete code to free memory used by
	internal units.
	(st_read_done): Use new function - free_internal_unit.
	(st_write_done): Use new function - free_internal unit.

From-SVN: r113190

5 files changed, 111 insertions, 30 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index bd02bbd..00acecf 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,23 @@
+2006-04-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/20257
+	* io/io.h: Add prototypes for get_internal_unit and free_internal_unit.
+	* io/unit.c (get_internal_unit): Initialize unit number, not zero.
+	(free_internal_unit): New function to consolidate freeing memory.
+	(get_unit): Initialize internal_unit_desc to NULL when unit is
+	external.
+	* io/unix.c (mem_close): Check for not NULL before freeing memory.
+	* io/transfer.c (read_block): Reset bytes_left and skip error if unit
+	is preconnected and default record length is reached.
+	(read_block_direct): Ditto.
+	(write_block): Ditto.
+	(write_buf): Ditto.
+	(data_transfer_init): Only flush if not internal unit.
+	(finalize_transfer): Ditto and delete code to free memory used by
+	internal units.
+	(st_read_done): Use new function - free_internal_unit.
+	(st_write_done): Use new function - free_internal unit.
+
 2006-04-22  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/26769
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index eed15ae..e7581a6 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -702,6 +702,12 @@ internal_proto(unit_lock);
 extern int close_unit (gfc_unit *);
 internal_proto(close_unit);
 
+extern gfc_unit *get_internal_unit (st_parameter_dt *);
+internal_proto(get_internal_unit);
+
+extern void free_internal_unit (st_parameter_dt *);
+internal_proto(free_internal_unit);
+
 extern int is_internal_unit (st_parameter_dt *);
 internal_proto(is_internal_unit);
 
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 11be456..7438401 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -257,11 +257,19 @@ read_block (st_parameter_dt *dtp, int *length)
 
   if (dtp->u.p.current_unit->bytes_left < *length)
     {
-      if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+      /* For preconnected units with default record length, set bytes left
+	 to unit record length and proceed, otherwise error.  */
+      if (dtp->u.p.current_unit->unit_number == options.stdin_unit
+	  && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+        dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+      else
 	{
-	  generate_error (&dtp->common, ERROR_EOR, NULL);
-	  /* Not enough data left.  */
-	  return NULL;
+	  if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+	    {
+	      /* Not enough data left.  */
+	      generate_error (&dtp->common, ERROR_EOR, NULL);
+	      return NULL;
+	    }
 	}
 
       *length = dtp->u.p.current_unit->bytes_left;
@@ -305,11 +313,19 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 
   if (dtp->u.p.current_unit->bytes_left < *nbytes)
     {
-      if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+      /* For preconnected units with default record length, set bytes left
+	 to unit record length and proceed, otherwise error.  */
+      if (dtp->u.p.current_unit->unit_number == options.stdin_unit
+	  && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+        dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+      else
 	{
-	  /* Not enough data left.  */
-	  generate_error (&dtp->common, ERROR_EOR, NULL);
-	  return;
+	  if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+	    {
+	      /* Not enough data left.  */
+	      generate_error (&dtp->common, ERROR_EOR, NULL);
+	      return;
+	    }
 	}
 
       *nbytes = dtp->u.p.current_unit->bytes_left;
@@ -358,11 +374,20 @@ void *
 write_block (st_parameter_dt *dtp, int length)
 {
   char *dest;
-  
+
   if (dtp->u.p.current_unit->bytes_left < length)
     {
-      generate_error (&dtp->common, ERROR_EOR, NULL);
-      return NULL;
+      /* For preconnected units with default record length, set bytes left
+	 to unit record length and proceed, otherwise error.  */
+      if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
+	  || dtp->u.p.current_unit->unit_number == options.stderr_unit)
+	  && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+        dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+      else
+	{
+	  generate_error (&dtp->common, ERROR_EOR, NULL);
+	  return NULL;
+	}
     }
 
   dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
@@ -388,11 +413,20 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 {
   if (dtp->u.p.current_unit->bytes_left < nbytes)
     {
-      if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
-	generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
+      /* For preconnected units with default record length, set bytes left
+	 to unit record length and proceed, otherwise error.  */
+      if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
+	  || dtp->u.p.current_unit->unit_number == options.stderr_unit)
+	  && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+        dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
       else
-	generate_error (&dtp->common, ERROR_EOR, NULL);
-      return FAILURE;
+	{
+	  if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+	    generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
+	  else
+	    generate_error (&dtp->common, ERROR_EOR, NULL);
+	  return FAILURE;
+	}
     }
 
   dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
@@ -1592,7 +1626,9 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 
       /* Check to see if we might be reading what we wrote before  */
 
-      if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode  == WRITING)
+      if (dtp->u.p.mode == READING
+	  && dtp->u.p.current_unit->mode == WRITING
+	  && !is_internal_unit (dtp))
 	 flush(dtp->u.p.current_unit->s);
 
       /* Check whether the record exists to be read.  Only
@@ -2186,7 +2222,8 @@ finalize_transfer (st_parameter_dt *dtp)
 	{
 	  /* Most systems buffer lines, so force the partial record
 	     to be written out.  */
-	  flush (dtp->u.p.current_unit->s);
+	  if (!is_internal_unit (dtp))
+	    flush (dtp->u.p.current_unit->s);
 	  dtp->u.p.seen_dollar = 0;
 	  return;
 	}
@@ -2195,16 +2232,8 @@ finalize_transfer (st_parameter_dt *dtp)
     }
 
   sfree (dtp->u.p.current_unit->s);
-
-  if (is_internal_unit (dtp))
-    {
-      if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
-	free_mem (dtp->u.p.current_unit->ls);
-      sclose (dtp->u.p.current_unit->s);
-    }
 }
 
-
 /* Transfer function for IOLENGTH. It doesn't actually do any
    data transfer, it just updates the length counter.  */
 
@@ -2318,8 +2347,9 @@ st_read_done (st_parameter_dt *dtp)
     free_mem (dtp->u.p.scratch);
   if (dtp->u.p.current_unit != NULL)
     unlock_unit (dtp->u.p.current_unit);
-  if (is_internal_unit (dtp) && dtp->u.p.current_unit != NULL)
-    free_mem (dtp->u.p.current_unit);
+
+  free_internal_unit (dtp);
+  
   library_end ();
 }
 
@@ -2372,8 +2402,9 @@ st_write_done (st_parameter_dt *dtp)
     free_mem (dtp->u.p.scratch);
   if (dtp->u.p.current_unit != NULL)
     unlock_unit (dtp->u.p.current_unit);
-  if (is_internal_unit (dtp) && dtp->u.p.current_unit != NULL)
-    free_mem (dtp->u.p.current_unit);
+  
+  free_internal_unit (dtp);
+
   library_end ();
 }
 
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index 81b128e..14438f8 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -378,6 +378,11 @@ get_internal_unit (st_parameter_dt *dtp)
   memset (iunit, '\0', sizeof (gfc_unit));
 
   iunit->recl = dtp->internal_unit_len;
+  
+  /* For internal units we set the unit number to -1.
+     Otherwise internal units can be mistaken for a pre-connected unit or
+     some other file I/O unit.  */
+  iunit->unit_number = -1;
 
   /* Set up the looping specification from the array descriptor, if any.  */
 
@@ -424,6 +429,23 @@ get_internal_unit (st_parameter_dt *dtp)
 }
 
 
+/* free_internal_unit()-- Free memory allocated for internal units if any.  */
+void
+free_internal_unit (st_parameter_dt *dtp)
+{
+  if (!is_internal_unit (dtp))
+    return;
+
+  if (dtp->u.p.current_unit->ls != NULL)
+      free_mem (dtp->u.p.current_unit->ls);
+  
+  sclose (dtp->u.p.current_unit->s);
+
+  if (dtp->u.p.current_unit != NULL)
+    free_mem (dtp->u.p.current_unit);
+}
+
+
 /* get_unit()-- Returns the unit structure associated with the integer
  * unit or the internal file. */
 
@@ -437,6 +459,7 @@ get_unit (st_parameter_dt *dtp, int do_create)
   /* Has to be an external unit */
 
   dtp->u.p.unit_is_internal = 0;
+  dtp->internal_unit_desc = NULL;
 
   return get_external_unit (dtp->common.unit, do_create);
 }
diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c
index 550ddab..93f4ea6 100644
--- a/libgfortran/io/unix.c
+++ b/libgfortran/io/unix.c
@@ -928,7 +928,8 @@ mem_truncate (unix_stream * s __attribute__ ((unused)))
 static try
 mem_close (unix_stream * s)
 {
-  free_mem (s);
+  if (s != NULL)
+    free_mem (s);
 
   return SUCCESS;
 }