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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@113190 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index bd02bbd..00acecf 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;
 }