re PR fortran/26766 ([F2003] Recursive I/O still (again) broken)

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

	PR libgfortran/26766
	* io/io.h: Add bit to identify associated unit as internal.
	* io/unit.c (get_external_unit): Renamed the find_unit_1 function to
	reflect the external unit functionality vs internal unit.
	(get_internal_unit): New function to allocate and initialize an internal
	unit structure.
	(get_unit): Use get_internal_unit and get_external_unit.
	(is_internal_unit): Revised to use new bit added in io.h.
	* io/transfer.c (data_transfer_init): Fix line width.
	(st_read_done): Free memory allocated for internal unit.
	(st_write_done): Add test to only flush and truncate when not an
	internal unit.  Free memory allocated for internal unit.

From-SVN: r112914

4 files changed, 106 insertions, 49 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 867645d..190d4a2 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,18 @@
+2006-04-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/26766
+	* io/io.h: Add bit to identify associated unit as internal.
+	* io/unit.c (get_external_unit): Renamed the find_unit_1 function to
+	reflect the external unit functionality vs internal unit.
+	(get_internal_unit): New function to allocate and initialize an internal
+	unit structure.
+	(get_unit): Use get_internal_unit and get_external_unit.
+	(is_internal_unit): Revised to use new bit added in io.h.
+	* io/transfer.c (data_transfer_init): Fix line width.
+	(st_read_done): Free memory allocated for internal unit.
+	(st_write_done): Add test to only flush and truncate when not an
+	internal unit.  Free memory allocated for internal unit.
+
 2006-04-11  Jakub Jelinek  <jakub@redhat.com>
 
 	* io/io.h (st_parameter_dt): Revert 2005-12-10 change to
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index cfb9401..eed15ae 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -414,7 +414,10 @@ typedef struct st_parameter_dt
           /* A namelist specific flag used to enable reading input from 
 	     line_buffer for logical reads.  */
 	  unsigned line_buffer_enabled : 1;
-	  /* 18 unused bits.  */
+	  /* An internal unit specific flag used to identify that the associated
+	     unit is internal.  */
+	  unsigned unit_is_internal : 1;
+	  /* 17 unused bits.  */
 
 	  char last_char;
 	  char nml_delim;
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 6097c35..11be456 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1619,7 +1619,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
      it is always safe to truncate the file on the first write */
   if (dtp->u.p.mode == WRITING
       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
-      && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s))
+      && dtp->u.p.current_unit->last_record == 0 
+      && !is_preconnected(dtp->u.p.current_unit->s))
 	struncate(dtp->u.p.current_unit->s);
 
   /* Bugware for badly written mixed C-Fortran I/O.  */
@@ -2317,6 +2318,8 @@ 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);
   library_end ();
 }
 
@@ -2353,10 +2356,12 @@ st_write_done (st_parameter_dt *dtp)
 
       case NO_ENDFILE:
 	/* Get rid of whatever is after this record.  */
-	flush (dtp->u.p.current_unit->s);
-	if (struncate (dtp->u.p.current_unit->s) == FAILURE)
-	  generate_error (&dtp->common, ERROR_OS, NULL);
-
+        if (!is_internal_unit (dtp))
+	  {
+	    flush (dtp->u.p.current_unit->s);
+	    if (struncate (dtp->u.p.current_unit->s) == FAILURE)
+	      generate_error (&dtp->common, ERROR_OS, NULL);
+	  }
 	dtp->u.p.current_unit->endfile = AT_ENDFILE;
 	break;
       }
@@ -2367,6 +2372,8 @@ 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);
   library_end ();
 }
 
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index 337e10c..81b128e 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -75,7 +75,7 @@ Boston, MA 02110-1301, USA.  */
 
 
 #define CACHE_SIZE 3
-static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
+static gfc_unit *unit_cache[CACHE_SIZE];
 gfc_offset max_offset;
 gfc_unit *unit_root;
 #ifdef __GTHREAD_MUTEX_INIT
@@ -260,12 +260,12 @@ delete_unit (gfc_unit * old)
 }
 
 
-/* find_unit()-- Given an integer, return a pointer to the unit
+/* get_external_unit()-- Given an integer, return a pointer to the unit
  * structure.  Returns NULL if the unit does not exist,
  * otherwise returns a locked unit. */
 
 static gfc_unit *
-find_unit_1 (int n, int do_create)
+get_external_unit (int n, int do_create)
 {
   gfc_unit *p;
   int c, created = 0;
@@ -346,58 +346,99 @@ found:
   return p;
 }
 
+
 gfc_unit *
 find_unit (int n)
 {
-  return find_unit_1 (n, 0);
+  return get_external_unit (n, 0);
 }
 
+
 gfc_unit *
 find_or_create_unit (int n)
 {
-  return find_unit_1 (n, 1);
+  return get_external_unit (n, 1);
 }
 
-/* get_unit()-- Returns the unit structure associated with the integer
- * unit or the internal file. */
 
 gfc_unit *
-get_unit (st_parameter_dt *dtp, int do_create)
+get_internal_unit (st_parameter_dt *dtp)
 {
-  if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
+  gfc_unit * iunit;
+
+  /* Allocate memory for a unit structure.  */
+
+  iunit = get_mem (sizeof (gfc_unit));
+  if (iunit == NULL)
     {
-      __gthread_mutex_lock (&internal_unit.lock);
-      internal_unit.recl = dtp->internal_unit_len;
-      if (is_array_io (dtp))
-	{
-	  internal_unit.rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
-	  internal_unit.ls = (array_loop_spec *)
-	    get_mem (internal_unit.rank * sizeof (array_loop_spec));
-	  dtp->internal_unit_len *=
-	    init_loop_spec (dtp->internal_unit_desc, internal_unit.ls);
-	}
+      generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
+      return NULL;
+    }
 
-      internal_unit.s =
-	open_internal (dtp->internal_unit, dtp->internal_unit_len);
-      internal_unit.bytes_left = internal_unit.recl;
-      internal_unit.last_record=0;
-      internal_unit.maxrec=0;
-      internal_unit.current_record=0;
+  memset (iunit, '\0', sizeof (gfc_unit));
 
-      /* Set flags for the internal unit */
+  iunit->recl = dtp->internal_unit_len;
 
-      internal_unit.flags.access = ACCESS_SEQUENTIAL;
-      internal_unit.flags.action = ACTION_READWRITE;
-      internal_unit.flags.form = FORM_FORMATTED;
-      internal_unit.flags.delim = DELIM_NONE;
-      internal_unit.flags.pad = PAD_YES;
+  /* Set up the looping specification from the array descriptor, if any.  */
 
-      return &internal_unit;
+  if (is_array_io (dtp))
+    {
+      iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
+      iunit->ls = (array_loop_spec *)
+	get_mem (iunit->rank * sizeof (array_loop_spec));
+      dtp->internal_unit_len *=
+	init_loop_spec (dtp->internal_unit_desc, iunit->ls);
     }
 
+  /* Set initial values for unit parameters.  */
+
+  iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len);
+  iunit->bytes_left = iunit->recl;
+  iunit->last_record=0;
+  iunit->maxrec=0;
+  iunit->current_record=0;
+  iunit->read_bad = 0;
+
+  /* Set flags for the internal unit.  */
+
+  iunit->flags.access = ACCESS_SEQUENTIAL;
+  iunit->flags.action = ACTION_READWRITE;
+  iunit->flags.form = FORM_FORMATTED;
+  iunit->flags.pad = PAD_YES;
+  iunit->flags.status = STATUS_UNSPECIFIED;
+
+  /* Initialize the data transfer parameters.  */
+
+  dtp->u.p.advance_status = ADVANCE_YES;
+  dtp->u.p.blank_status = BLANK_UNSPECIFIED;
+  dtp->u.p.seen_dollar = 0;
+  dtp->u.p.skips = 0;
+  dtp->u.p.pending_spaces = 0;
+  dtp->u.p.max_pos = 0;
+
+  /* This flag tells us the unit is assigned to internal I/O.  */
+  
+  dtp->u.p.unit_is_internal = 1;
+
+  return iunit;
+}
+
+
+/* get_unit()-- Returns the unit structure associated with the integer
+ * unit or the internal file. */
+
+gfc_unit *
+get_unit (st_parameter_dt *dtp, int do_create)
+{
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
+    return get_internal_unit(dtp);
+
   /* Has to be an external unit */
 
-  return find_unit_1 (dtp->common.unit, do_create);
+  dtp->u.p.unit_is_internal = 0;
+
+  return get_external_unit (dtp->common.unit, do_create);
 }
 
 
@@ -406,7 +447,7 @@ get_unit (st_parameter_dt *dtp, int do_create)
 int
 is_internal_unit (st_parameter_dt *dtp)
 {
-  return dtp->u.p.current_unit == &internal_unit;
+  return dtp->u.p.unit_is_internal;
 }
 
 
@@ -432,15 +473,6 @@ init_units (void)
   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 #endif
 
-#ifdef __GTHREAD_MUTEX_INIT
-  {
-    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
-    internal_unit.lock = tmp;
-  }
-#else
-  __GTHREAD_MUTEX_INIT_FUNCTION (&internal_unit.lock);
-#endif
-
   if (options.stdin_unit >= 0)
     {				/* STDIN */
       u = insert_unit (options.stdin_unit);