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

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

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);
 

libgfortran/io/transfer.c

@@ -256,13 +256,21 @@ read_block (st_parameter_dt *dtp, int *length)
   int nread;
 
   if (dtp->u.p.current_unit->bytes_left < *length)
+    {
+      /* 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
 	{
 	  if (dtp->u.p.current_unit->flags.pad == PAD_NO)
 	    {
-	  generate_error (&dtp->common, ERROR_EOR, NULL);
 	      /* Not enough data left.  */
+	      generate_error (&dtp->common, ERROR_EOR, NULL);
 	      return NULL;
 	    }
+	}
 
       *length = dtp->u.p.current_unit->bytes_left;
     }
@@ -304,6 +312,13 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
   size_t nread;
 
   if (dtp->u.p.current_unit->bytes_left < *nbytes)
+    {
+      /* 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
 	{
 	  if (dtp->u.p.current_unit->flags.pad == PAD_NO)
 	    {
@@ -311,6 +326,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 	      generate_error (&dtp->common, ERROR_EOR, NULL);
 	      return;
 	    }
+	}
 
       *nbytes = dtp->u.p.current_unit->bytes_left;
     }
@@ -360,10 +376,19 @@ write_block (st_parameter_dt *dtp, int length)
   char *dest;
 
   if (dtp->u.p.current_unit->bytes_left < length)
+    {
+      /* 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;
   dest = salloc_w (dtp->u.p.current_unit->s, &length);
@@ -387,6 +412,14 @@ static try
 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 {
   if (dtp->u.p.current_unit->bytes_left < nbytes)
+    {
+      /* 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
 	{
 	  if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 	    generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
@@ -394,6 +427,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 	    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,6 +2222,7 @@ finalize_transfer (st_parameter_dt *dtp)
 	{
 	  /* Most systems buffer lines, so force the partial record
 	     to be written out.  */
+	  if (!is_internal_unit (dtp))
 	    flush (dtp->u.p.current_unit->s);
 	  dtp->u.p.seen_dollar = 0;
 	  return;
@@ -2195,15 +2232,7 @@ 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 ();
 }
 

libgfortran/io/unit.c

@@ -379,6 +379,11 @@ get_internal_unit (st_parameter_dt *dtp)
 
   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.  */
 
   if (is_array_io (dtp))
@@ -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);
 }

libgfortran/io/unix.c

@@ -928,6 +928,7 @@ mem_truncate (unix_stream * s __attribute__ ((unused)))
 static try
 mem_close (unix_stream * s)
 {
+  if (s != NULL)
     free_mem (s);
 
   return SUCCESS;