re PR fortran/48298 ([F03] User-Defined Derived-Type IO (DTIO))

2016-09-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/48298
	* io/inquire.c (inquire_via_unit): Adjust error check for the
	two possible internal unit KINDs.
	* io/io.h: Adjust defines for is_internal_unit and
	is_char4_unit. (gfc_unit): Add internal unit data to structure.
	(get_internal_unit): Change declaration to set_internal_unit.
	(free_internal_unit): Change name to stash_internal_unit_number.
	(get_unique_unit_number): Adjust parameter argument.
	Define IOPARM_DT_HAS_UDTIO. (gfc_saved_unit): New structure.
	* io/list_read.c (next_char_internal): Use is_char4_unit.
	* io/open.c (st_open): Adjust call to get_unique_unit_number.
	* io/transfer.c (write_block): Use is_char4_unit.
	(data_transfer_init): Update check for unit numbers.
	(st_read_done): Free the various allocated memories used for the
	internal units and stash the negative unit number and pointer to unit
	structure to allow reuse. (st_write_done): Likewise stash the freed
	unit.
	* io/unit.c: Create a fixed size buffer of 16 gfc_saved_unit's to use
	as a stack to save newunit unit numbers and unit structure for reuse.
	(get_external_unit): Change name to get_gfc_unit to better
	reflect what it does. (find_unit): Change call to get_gfc_unit.
	(find_or_create_unit): Likewise. (get_internal_unit): Change
	name to set_internal_unit. Move internal unit from the dtp
	structure to the gfc_unit structure so that it can be passed to
	child I/O statements through the UNIT.
	(free_internal_unit): Change name to stash_internal_unit_number.
	Push the common.unit number onto the newunit stack, saving it
	for possible reuse later. (get_unit): Set the internal unit
	KIND. Use get_unique_unit_number to get a negative unit number
	for the internal unit. Use get_gfc_unit to get the unit structure
	and use set_internal_unit to initialize it.
	(init_units): Initialize the newunit stack.
	(get_unique_unit_number): Check the stack for an available unit
	number and use it. If none there get the next most negative
	number. (close_units): Free any unit structures pointed to from the save
	stack.

2016-09-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/48298
	* gfortran.h (gfc_dt): Add *udtio.
	* ioparm.def: Add bit IOPARM_dt_f2003 to align with library use of bit
	25. Add IOPARM_dt_dtio bit to common flags.
	* resolve.c (resolve_transfer): Set dt->udtio to expression.
	* io.c (gfc_match_inquire): Adjust error message for internal
	unit KIND.
	* libgfortran.h: Adjust defines for GFC_INTERNAL_UNIT4,
	GFC_INTERNAL_UNIT, and GFC_INVALID_UNIT.
	* trans-io.c (build_dt): Set common_unit to reflect the KIND of
	the internal unit. Set mask bit for presence of dt->udtio.

2016-09-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/48298
	* gfortran.dg/negative_unit_check.f90: Update test.
	* gfortran.dg/dtio_14.f90: New test.

From-SVN: r240456

7 files changed, 226 insertions, 123 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 3edd9ed..f312a06 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,42 @@
+2016-09-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/48298
+	* io/inquire.c (inquire_via_unit): Adjust error check for the
+	two possible internal unit KINDs.
+	* io/io.h: Adjust defines for is_internal_unit and
+	is_char4_unit. (gfc_unit): Add internal unit data to structure.
+	(get_internal_unit): Change declaration to set_internal_unit.
+	(free_internal_unit): Change name to stash_internal_unit_number.
+	(get_unique_unit_number): Adjust parameter argument.
+	Define IOPARM_DT_HAS_UDTIO. (gfc_saved_unit): New structure.
+	* io/list_read.c (next_char_internal): Use is_char4_unit.
+	* io/open.c (st_open): Adjust call to get_unique_unit_number.
+	* io/transfer.c (write_block): Use is_char4_unit.
+	(data_transfer_init): Update check for unit numbers.
+	(st_read_done): Free the various allocated memories used for the
+	internal units and stash the negative unit number and pointer to unit
+	structure to allow reuse. (st_write_done): Likewise stash the freed
+	unit.
+	* io/unit.c: Create a fixed size buffer of 16 gfc_saved_unit's to use
+	as a stack to save newunit unit numbers and unit structure for reuse.
+	(get_external_unit): Change name to get_gfc_unit to better
+	reflect what it does. (find_unit): Change call to get_gfc_unit.
+	(find_or_create_unit): Likewise. (get_internal_unit): Change
+	name to set_internal_unit. Move internal unit from the dtp
+	structure to the gfc_unit structure so that it can be passed to
+	child I/O statements through the UNIT.
+	(free_internal_unit): Change name to stash_internal_unit_number.
+	Push the common.unit number onto the newunit stack, saving it
+	for possible reuse later. (get_unit): Set the internal unit
+	KIND. Use get_unique_unit_number to get a negative unit number
+	for the internal unit. Use get_gfc_unit to get the unit structure
+	and use set_internal_unit to initialize it.
+	(init_units): Initialize the newunit stack.
+	(get_unique_unit_number): Check the stack for an available unit
+	number and use it. If none there get the next most negative
+	number. (close_units): Free any unit structures pointed to from the save
+	stack.
+
 2016-09-21  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	* intrinsics/random.c (getosrandom): Use rand_s() on
diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c
index ae5ba62..2bb518b 100644
--- a/libgfortran/io/inquire.c
+++ b/libgfortran/io/inquire.c
@@ -41,7 +41,7 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
   const char *p;
   GFC_INTEGER_4 cf = iqp->common.flags;
 
-  if (iqp->common.unit == GFC_INTERNAL_UNIT)
+  if (iqp->common.unit == GFC_INTERNAL_UNIT || iqp->common.unit == GFC_INTERNAL_UNIT4)
     generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL);
 
   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index ff75741..87c3558 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -69,11 +69,11 @@ internal_proto(old_locale_lock);
 
 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
 
-#define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
+#define is_internal_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind)
 
 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
 
-#define is_char4_unit(dtp) ((dtp)->u.p.unit_is_internal && (dtp)->common.unit)
+#define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4)
 
 /* The array_loop_spec contains the variables for the loops over index ranges
    that are encountered.  */
@@ -409,6 +409,7 @@ st_parameter_inquire;
 #define IOPARM_DT_HAS_ROUND			(1 << 23)
 #define IOPARM_DT_HAS_SIGN			(1 << 24)
 #define IOPARM_DT_HAS_F2003                     (1 << 25)
+#define IOPARM_DT_HAS_UDTIO                     (1 << 26)
 /* Internal use bit.  */
 #define IOPARM_DT_IONML_SET			(1u << 31)
 
@@ -640,12 +641,24 @@ typedef struct gfc_unit
   int (*next_char_fn_ptr) (st_parameter_dt *);
   void (*push_char_fn_ptr) (st_parameter_dt *, int);
 
+  /* Internal unit char string data.  */
+  char * internal_unit;
+  gfc_charlen_type internal_unit_len;
+  gfc_array_char *string_unit_desc;
+  int internal_unit_kind;
+
   /* DTIO Parent/Child procedure, 0 = parent, >0 = child level.  */
   int child_dtio;
   int last_char;
 }
 gfc_unit;
 
+typedef struct gfc_saved_unit
+{
+  GFC_INTEGER_4 unit_number;
+  gfc_unit *unit;
+}
+gfc_saved_unit;
 
 /* unit.c */
 
@@ -663,11 +676,11 @@ 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 gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int);
+internal_proto(set_internal_unit);
 
-extern void free_internal_unit (st_parameter_dt *);
-internal_proto(free_internal_unit);
+extern void stash_internal_unit (st_parameter_dt *);
+internal_proto(stash_internal_unit);
 
 extern gfc_unit *find_unit (int);
 internal_proto(find_unit);
@@ -687,7 +700,7 @@ internal_proto (finish_last_advance_record);
 extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *);
 internal_proto (unit_truncate);
 
-extern GFC_INTEGER_4 get_unique_unit_number (st_parameter_open *);
+extern GFC_INTEGER_4 get_unique_unit_number (st_parameter_common *);
 internal_proto(get_unique_unit_number);
 
 /* open.c */
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index a42f12b..f258c9d 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -267,7 +267,7 @@ next_char_internal (st_parameter_dt *dtp)
 
   /* Get the next character and handle end-of-record conditions.  */
 
-  if (dtp->common.unit) /* Check for kind=4 internal unit.  */
+  if (is_char4_unit(dtp)) /* Check for kind=4 internal unit.  */
    length = sread (dtp->u.p.current_unit->s, &c, 1);
   else
    {
@@ -390,7 +390,7 @@ eat_spaces (st_parameter_dt *dtp)
       gfc_offset offset = stell (dtp->u.p.current_unit->s);
       gfc_offset i;
 
-      if (dtp->common.unit) /* kind=4 */
+      if (is_char4_unit(dtp)) /* kind=4 */
 	{
 	  for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++)
 	    {
diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c
index d159189..d074b02 100644
--- a/libgfortran/io/open.c
+++ b/libgfortran/io/open.c
@@ -812,7 +812,7 @@ st_open (st_parameter_open *opp)
   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
     {
       if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
-	opp->common.unit = get_unique_unit_number(opp);
+	opp->common.unit = get_unique_unit_number(&opp->common);
       else if (opp->common.unit < 0)
 	{
 	  u = find_unit (opp->common.unit);
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 98072d0..6009c12 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -737,7 +737,7 @@ write_block (st_parameter_dt *dtp, int length)
 
   if (is_internal_unit (dtp))
     {
-      if (dtp->common.unit) /* char4 internel unit.  */
+      if (is_char4_unit(dtp)) /* char4 internel unit.  */
 	{
 	  gfc_char4_t *dest4;
 	  dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
@@ -2606,7 +2606,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
        st_parameter_open opp;
        unit_convert conv;
 
-      if (dtp->common.unit < 0)
+      if (dtp->common.unit < 0 && !is_internal_unit (dtp))
 	{
 	  close_unit (dtp->u.p.current_unit);
 	  dtp->u.p.current_unit = NULL;
@@ -3943,18 +3943,34 @@ st_read_done (st_parameter_dt *dtp)
 {
   finalize_transfer (dtp);
 
-  if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
-    {
-      free_format_data (dtp->u.p.fmt);
-      free_format (dtp);
-    }
-
   free_ionml (dtp);
 
-  if (dtp->u.p.current_unit != NULL)
-    unlock_unit (dtp->u.p.current_unit);
-
-  free_internal_unit (dtp);
+  /* If this is a parent READ statement we do not need to retain the
+     internal unit structure for child use.  Free it and stash the unit
+     number for reuse.  */
+  if (dtp->u.p.current_unit != NULL
+      && dtp->u.p.current_unit->child_dtio == 0)
+    {
+      if (is_internal_unit (dtp) &&
+	  (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+        {
+	  free (dtp->u.p.current_unit->filename);
+	  dtp->u.p.current_unit->filename = NULL;
+	  free_format_hash_table (dtp->u.p.current_unit);
+	  free (dtp->u.p.current_unit->s);
+	  dtp->u.p.current_unit->s = NULL;
+	  if (dtp->u.p.current_unit->ls)
+	    free (dtp->u.p.current_unit->ls);
+	  dtp->u.p.current_unit->ls = NULL;
+	  stash_internal_unit (dtp);
+	}
+      if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+	{
+	  free_format_data (dtp->u.p.fmt);
+	  free_format (dtp);
+	}
+      unlock_unit (dtp->u.p.current_unit);
+    }
 
   library_end ();
 }
@@ -3977,43 +3993,55 @@ st_write_done (st_parameter_dt *dtp)
 {
   finalize_transfer (dtp);
 
-  /* Deal with endfile conditions associated with sequential files.  */
-
   if (dtp->u.p.current_unit != NULL
-      && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
       && dtp->u.p.current_unit->child_dtio == 0)
-    switch (dtp->u.p.current_unit->endfile)
-      {
-      case AT_ENDFILE:		/* Remain at the endfile record.  */
-	break;
-
-      case AFTER_ENDFILE:
-	dtp->u.p.current_unit->endfile = AT_ENDFILE;	/* Just at it now.  */
-	break;
-
-      case NO_ENDFILE:
-	/* Get rid of whatever is after this record.  */
-        if (!is_internal_unit (dtp))
-          unit_truncate (dtp->u.p.current_unit,
-                         stell (dtp->u.p.current_unit->s),
-                         &dtp->common);
-	dtp->u.p.current_unit->endfile = AT_ENDFILE;
-	break;
-      }
-
-  if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
     {
-      free_format_data (dtp->u.p.fmt);
-      free_format (dtp);
-    }
+      /* Deal with endfile conditions associated with sequential files.  */
+      if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+	switch (dtp->u.p.current_unit->endfile)
+	  {
+	  case AT_ENDFILE:		/* Remain at the endfile record.  */
+	    break;
 
-  free_ionml (dtp);
+	  case AFTER_ENDFILE:
+	    dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now.  */
+	    break;
 
-  if (dtp->u.p.current_unit != NULL)
-    unlock_unit (dtp->u.p.current_unit);
+	  case NO_ENDFILE:
+	    /* Get rid of whatever is after this record.  */
+	    if (!is_internal_unit (dtp))
+	      unit_truncate (dtp->u.p.current_unit,
+			     stell (dtp->u.p.current_unit->s),
+			     &dtp->common);
+	    dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	    break;
+	  }
 
-  free_internal_unit (dtp);
+      free_ionml (dtp);
 
+      /* If this is a parent WRITE statement we do not need to retain the
+	 internal unit structure for child use.  Free it and stash the
+	 unit number for reuse.  */
+      if (is_internal_unit (dtp) &&
+	  (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+	{
+	  free (dtp->u.p.current_unit->filename);
+	  dtp->u.p.current_unit->filename = NULL;
+	  free_format_hash_table (dtp->u.p.current_unit);
+	  free (dtp->u.p.current_unit->s);
+	  dtp->u.p.current_unit->s = NULL;
+	  if (dtp->u.p.current_unit->ls)
+	    free (dtp->u.p.current_unit->ls);
+	  dtp->u.p.current_unit->ls = NULL;
+	  stash_internal_unit (dtp);
+	}
+      if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+	{
+	  free_format_data (dtp->u.p.fmt);
+	  free_format (dtp);
+	}
+      unlock_unit (dtp->u.p.current_unit);
+    }
   library_end ();
 }
 
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index fde9ac7..274b24b 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -72,8 +72,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 
 /* Unit number to be assigned when NEWUNIT is used in an OPEN statement.  */
 #define GFC_FIRST_NEWUNIT -10
+#define NEWUNIT_STACK_SIZE 16
 static GFC_INTEGER_4 next_available_newunit = GFC_FIRST_NEWUNIT;
 
+/* A stack to save previously used newunit-assigned unit numbers to
+   allow them to be reused without reallocating the gfc_unit structure
+   which is still in the treap.  */
+static gfc_saved_unit newunit_stack[NEWUNIT_STACK_SIZE];
+static int newunit_tos = 0; /* Index to Top of Stack.  */
+
 #define CACHE_SIZE 3
 static gfc_unit *unit_cache[CACHE_SIZE];
 gfc_offset max_offset;
@@ -294,12 +301,12 @@ delete_unit (gfc_unit * old)
 }
 
 
-/* get_external_unit()-- Given an integer, return a pointer to the unit
+/* get_gfc_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 *
-get_external_unit (int n, int do_create)
+get_gfc_unit (int n, int do_create)
 {
   gfc_unit *p;
   int c, created = 0;
@@ -361,6 +368,7 @@ found:
       inc_waiting_locked (p);
     }
 
+
   __gthread_mutex_unlock (&unit_lock);
 
   if (p != NULL && (p->child_dtio == 0))
@@ -384,14 +392,14 @@ found:
 gfc_unit *
 find_unit (int n)
 {
-  return get_external_unit (n, 0);
+  return get_gfc_unit (n, 0);
 }
 
 
 gfc_unit *
 find_or_create_unit (int n)
 {
-  return get_external_unit (n, 1);
+  return get_gfc_unit (n, 1);
 }
 
 
@@ -426,31 +434,14 @@ is_trim_ok (st_parameter_dt *dtp)
 
 
 gfc_unit *
-get_internal_unit (st_parameter_dt *dtp)
+set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
 {
-  gfc_unit * iunit;
   gfc_offset start_record = 0;
 
-  /* Allocate memory for a unit structure.  */
-
-  iunit = xcalloc (1, sizeof (gfc_unit));
-
-#ifdef __GTHREAD_MUTEX_INIT
-  {
-    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
-    iunit->lock = tmp;
-  }
-#else
-  __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
-#endif
-  __gthread_mutex_lock (&iunit->lock);
-
   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;
+  iunit->internal_unit = dtp->internal_unit;
+  iunit->internal_unit_len = dtp->internal_unit_len;
+  iunit->internal_unit_kind = kind;
 
   /* As an optimization, adjust the unit record length to not
      include trailing blanks. This will not work under certain conditions
@@ -458,14 +449,14 @@ get_internal_unit (st_parameter_dt *dtp)
   if (dtp->u.p.mode == READING && is_trim_ok (dtp))
     {
       int len;
-      if (dtp->common.unit == 0)
-	  len = string_len_trim (dtp->internal_unit_len,
-						   dtp->internal_unit);
+      if (kind == 1)
+	  len = string_len_trim (iunit->internal_unit_len,
+						   iunit->internal_unit);
       else
-	  len = string_len_trim_char4 (dtp->internal_unit_len,
-			      (const gfc_char4_t*) dtp->internal_unit);
-      dtp->internal_unit_len = len;
-      iunit->recl = dtp->internal_unit_len;
+	  len = string_len_trim_char4 (iunit->internal_unit_len,
+			      (const gfc_char4_t*) iunit->internal_unit);
+      iunit->internal_unit_len = len;
+      iunit->recl = iunit->internal_unit_len;
     }
 
   /* Set up the looping specification from the array descriptor, if any.  */
@@ -475,22 +466,19 @@ get_internal_unit (st_parameter_dt *dtp)
       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
       iunit->ls = (array_loop_spec *)
 	xmallocarray (iunit->rank, sizeof (array_loop_spec));
-      dtp->internal_unit_len *=
+      iunit->internal_unit_len *=
 	init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
 
       start_record *= iunit->recl;
     }
 
   /* Set initial values for unit parameters.  */
-  if (dtp->common.unit)
-    {
-      iunit->s = open_internal4 (dtp->internal_unit - start_record,
-				 dtp->internal_unit_len, -start_record);
-      fbuf_init (iunit, 256);
-    }
+  if (kind == 4)
+    iunit->s = open_internal4 (iunit->internal_unit - start_record,
+				 iunit->internal_unit_len, -start_record);
   else
-    iunit->s = open_internal (dtp->internal_unit - start_record,
-			      dtp->internal_unit_len, -start_record);
+    iunit->s = open_internal (iunit->internal_unit - start_record,
+			      iunit->internal_unit_len, -start_record);
 
   iunit->bytes_left = iunit->recl;
   iunit->last_record=0;
@@ -522,33 +510,22 @@ get_internal_unit (st_parameter_dt *dtp)
   dtp->u.p.pending_spaces = 0;
   dtp->u.p.max_pos = 0;
   dtp->u.p.at_eof = 0;
-
-  /* This flag tells us the unit is assigned to internal I/O.  */
-
-  dtp->u.p.unit_is_internal = 1;
-
   return iunit;
 }
 
 
-/* free_internal_unit()-- Free memory allocated for internal units if any.  */
+/* stash_internal_unit()-- Push the internal unit number onto the
+   avaialble stack.  */
 void
-free_internal_unit (st_parameter_dt *dtp)
+stash_internal_unit (st_parameter_dt *dtp)
 {
-  if (!is_internal_unit (dtp))
-    return;
-
-  if (unlikely (is_char4_unit (dtp)))
-    fbuf_destroy (dtp->u.p.current_unit);
-
-  if (dtp->u.p.current_unit != NULL)
-    {
-      free (dtp->u.p.current_unit->ls);
-
-      free (dtp->u.p.current_unit->s);
-
-      destroy_unit_mutex (dtp->u.p.current_unit);
-    }
+  __gthread_mutex_lock (&unit_lock);
+  newunit_tos++;
+  if (newunit_tos >= NEWUNIT_STACK_SIZE)
+    internal_error (&dtp->common, "stash_internal_unit(): Stack Size Exceeded");
+  newunit_stack[newunit_tos].unit_number = dtp->common.unit;
+  newunit_stack[newunit_tos].unit = dtp->u.p.current_unit;
+  __gthread_mutex_unlock (&unit_lock);
 }
 
 
@@ -559,16 +536,51 @@ free_internal_unit (st_parameter_dt *dtp)
 gfc_unit *
 get_unit (st_parameter_dt *dtp, int do_create)
 {
+  gfc_unit * unit;
 
   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
-    return get_internal_unit (dtp);
+    {
+      int kind;
+      if (dtp->common.unit == GFC_INTERNAL_UNIT)
+        kind = 1;
+      else if (dtp->common.unit == GFC_INTERNAL_UNIT4)
+        kind = 4;
+      else
+	internal_error (&dtp->common, "get_unit(): Bad internal unit KIND");
 
+      if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) != 0)
+	{
+	  dtp->u.p.unit_is_internal = 1;
+	  dtp->common.unit = get_unique_unit_number (&dtp->common);
+	  unit = get_gfc_unit (dtp->common.unit, do_create);
+	  set_internal_unit (dtp, unit, kind);
+	  fbuf_init (unit, 128);
+	  return unit;
+	}
+      else
+	{
+	  if (newunit_tos)
+	    {
+	      dtp->common.unit = newunit_stack[newunit_tos].unit_number;
+	      unit = newunit_stack[newunit_tos--].unit;
+	      unit->fbuf->act = unit->fbuf->pos = 0;
+	    }
+	  else
+	    {
+	      dtp->common.unit = get_unique_unit_number (&dtp->common);
+	      unit = xcalloc (1, sizeof (gfc_unit));
+	      fbuf_init (unit, 128);
+	    }
+	  set_internal_unit (dtp, unit, kind);
+	  return unit;
+	}
+    }
   /* Has to be an external unit.  */
-
   dtp->u.p.unit_is_internal = 0;
+  dtp->internal_unit = NULL;
   dtp->internal_unit_desc = NULL;
-
-  return get_external_unit (dtp->common.unit, do_create);
+  unit = get_gfc_unit (dtp->common.unit, do_create);
+  return unit;
 }
 
 
@@ -687,6 +699,10 @@ init_units (void)
   max_offset = 0;
   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
     max_offset = max_offset + ((gfc_offset) 1 << i);
+
+  /* Initialize the newunit stack.  */
+  memset (newunit_stack, 0, NEWUNIT_STACK_SIZE * sizeof(gfc_saved_unit));
+  newunit_tos = 0;
 }
 
 
@@ -765,6 +781,13 @@ close_units (void)
     close_unit_1 (unit_root, 1);
   __gthread_mutex_unlock (&unit_lock);
 
+  while (newunit_tos != 0)
+    if (newunit_stack[newunit_tos].unit)
+      {
+	fbuf_destroy (newunit_stack[newunit_tos].unit);
+	free (newunit_stack[newunit_tos].unit->s);
+	free (newunit_stack[newunit_tos--].unit);
+      }
 #ifdef HAVE_FREELOCALE
   freelocale (c_locale);
 #endif
@@ -862,9 +885,10 @@ finish_last_advance_record (gfc_unit *u)
   fbuf_flush (u, u->mode);
 }
 
-/* Assign a negative number for NEWUNIT in OPEN statements.  */
+/* Assign a negative number for NEWUNIT in OPEN statements or for
+   internal units.  */
 GFC_INTEGER_4
-get_unique_unit_number (st_parameter_open *opp)
+get_unique_unit_number (st_parameter_common *common)
 {
   GFC_INTEGER_4 num;
 
@@ -875,11 +899,10 @@ get_unique_unit_number (st_parameter_open *opp)
   num = next_available_newunit--;
   __gthread_mutex_unlock (&unit_lock);
 #endif
-
   /* Do not allow NEWUNIT numbers to wrap.  */
   if (num > GFC_FIRST_NEWUNIT)
     {
-      generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
+      generate_error (common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
       return 0;
     }
   return num;