[patch,libgfortran] PR48298 DTIO implementation for Internal Units

[Jerry DeLisle <jvdelisle at charter dot net>]

Hi All,

The attached patch implements the necessary changes for DTIO to/from internal units.

Prior to this patch, internal unit character strings and related data were kept 
within the dtp structure with a pseudo unit number assigned. Since child I/O 
procedures need this information passed to them through the unit number, it is 
necessary to move this information into the gfc_unit structure.

This also implies that the internal unit needs a legitimate and unique unit 
number. This is accomplished using the existing newunit mechanisms to obtain a 
unit number and then allocating the unit structure on the existing treap 
mechanism used for all units.  The child I/O procedures can then find the units 
for use.

The existing method of getting a newunit number simply decrements an integer 
which then contains the next available number.  One problem with this is that 
with internal units used inside a loop, each call will get the next number and 
one will end up with hundreds or many thousands of units.

To work around this I implemented a stack to save unit numbers. After the 
internal unit I/O is completed, the unit structure is left on the treap and the 
unit number is saved on the stack, The next time an internal unit number is 
needed, it will be popped off this stack and used.  Since the associated unit 
structure remains on the treap, it is found and reused, without having to 
reallocate memory for it.

Once all these changes are made to the handling of internal units, the existing 
DTIO just works as usual.

Regression tested on x86-64 linux. New test case attached.

OK for trunk?

Regards,

Jerry

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

	PR fortran/48298
	* 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.

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

	PR fortran/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.
	* 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 to allow
	reuse. (st_write_done): Likewise stash the freed unit number.
	* io/unit.c: Create a fixed size buffer of 256 integers to use
	as a stack to save newunit unit numbers for later 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.

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 53037e22..48c15ef5 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -4256,9 +4256,11 @@ gfc_match_inquire (void)
 
   if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT
       && inquire->unit->ts.type == BT_INTEGER
-      && mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT)
+      && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4)
+      || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT)))
     {
-      gfc_error ("UNIT number in INQUIRE statement at %L can not be -1", &loc);
+      gfc_error ("UNIT number in INQUIRE statement at %L can not "
+		 "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer));
       goto cleanup;
     }
 
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index e9132506..cc355086 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -68,10 +68,11 @@ along with GCC; see the file COPYING3.  If not see
 				| GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO \
 				| GFC_RTCHECK_POINTER | GFC_RTCHECK_MEM)
 
-/* Special unit numbers used to convey certain conditions.  Numbers -3
+/* Special unit numbers used to convey certain conditions.  Numbers -4
    thru -9 available.  NEWUNIT values start at -10.  */
-#define GFC_INTERNAL_UNIT -1
-#define GFC_INVALID_UNIT  -2
+#define GFC_INTERNAL_UNIT4 -1    /* KIND=4 Internal Unit.  */
+#define GFC_INTERNAL_UNIT  -2    /* KIND=1 Internal Unit.  */
+#define GFC_INVALID_UNIT   -3
 
 /* Possible values for the CONVERT I/O specifier.  */
 /* Keep in sync with GFC_FLAG_CONVERT_* in gcc/flags.h.  */
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 2c843497..7d975f6a 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1808,7 +1808,8 @@ build_dt (tree function, gfc_code * code)
 	  mask |= set_internal_unit (&block, &post_iu_block,
 				     var, dt->io_unit);
 	  set_parameter_const (&block, var, IOPARM_common_unit,
-			       dt->io_unit->ts.kind == 1 ? 0 : -1);
+			       dt->io_unit->ts.kind == 1 ?
+			        GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
 	}
     }
   else
diff --git a/gcc/testsuite/gfortran.dg/negative_unit_check.f90 b/gcc/testsuite/gfortran.dg/negative_unit_check.f90
index 2a1b16c1..002b5b4a 100644
--- a/gcc/testsuite/gfortran.dg/negative_unit_check.f90
+++ b/gcc/testsuite/gfortran.dg/negative_unit_check.f90
@@ -2,4 +2,5 @@
 !  Test case from PR61933.
    LOGICAL :: file_exists
    INQUIRE(UNIT=-1,EXIST=file_exists)! { dg-error "can not be -1" }
+   INQUIRE(UNIT=-2,EXIST=file_exists)! { dg-error "can not be -2" }
 END
diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c
index ae5ba622..2bb518b6 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 ff75741e..96279f20 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.  */
@@ -640,6 +640,12 @@ 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;
@@ -663,11 +669,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_number (st_parameter_dt *);
+internal_proto(stash_internal_unit_number);
 
 extern gfc_unit *find_unit (int);
 internal_proto(find_unit);
@@ -687,7 +693,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 a42f12b7..f258c9d9 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 d1591898..d074b020 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 98072d0b..ee5d2021 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))
+        {
+	  fbuf_destroy (dtp->u.p.current_unit);
+	  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_number (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))
+        {
+	  fbuf_destroy (dtp->u.p.current_unit);
+	  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_number (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 fde9ac75..970bb1a2 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 256
 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_INTEGER_4 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,20 @@ 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);
+  fbuf_init (iunit, 256);
 
   iunit->bytes_left = iunit->recl;
   iunit->last_record=0;
@@ -522,33 +511,21 @@ 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_number (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] = dtp->common.unit;
+  __gthread_mutex_unlock (&unit_lock);
 }
 
 
@@ -559,16 +536,30 @@ 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");
 
+      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);
+      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 +678,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(int));
+  newunit_tos = 0;
 }
 
 
@@ -862,24 +857,27 @@ 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;
 
-#ifdef HAVE_SYNC_FETCH_AND_ADD
-  num = __sync_fetch_and_add (&next_available_newunit, -1);
-#else
   __gthread_mutex_lock (&unit_lock);
-  num = next_available_newunit--;
+  if (newunit_tos > 0)
+    {
+      num = newunit_stack[newunit_tos];
+      newunit_tos--;
+    }
+  else
+    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;

! { dg-do run }
!
! Functional test of User Defined Derived Type IO with typebound bindings
! This version tests IO to internal character units.
!
MODULE p
  TYPE :: person
    CHARACTER (LEN=20) :: name
    INTEGER(4) :: age
    CONTAINS
      procedure :: pwf
      procedure :: prf
      GENERIC :: WRITE(FORMATTED) => pwf
      GENERIC :: READ(FORMATTED) => prf
  END TYPE person
CONTAINS
  SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
    CLASS(person), INTENT(IN) :: dtv
    INTEGER, INTENT(IN) :: unit
    CHARACTER (LEN=*), INTENT(IN) :: iotype
    INTEGER, INTENT(IN) :: vlist(:)
    INTEGER, INTENT(OUT) :: iostat
    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
    WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age
  END SUBROUTINE pwf

  SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
    CLASS(person), INTENT(INOUT) :: dtv
    INTEGER, INTENT(IN) :: unit
    CHARACTER (LEN=*), INTENT(IN) :: iotype
    INTEGER, INTENT(IN) :: vlist(:)
    INTEGER, INTENT(OUT) :: iostat
    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
    READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
  END SUBROUTINE prf
END MODULE p

PROGRAM test
  USE p
  TYPE (person) :: chairman, answer
  character(kind=1,len=80) :: str1
  character(kind=4,len=80) :: str4
  str1 = ""
  str4 = 4_""
  chairman%name="Charlie"
  chairman%age=62
  answer = chairman
! KIND=1 test
  write (str1, *) chairman
  if (trim(str1).ne."  Charlie                       62") call abort
  chairman%name="Bogus"
  chairman%age=99
  read (str1, *) chairman
  if (chairman%name.ne.answer%name) call abort
  if (chairman%age.ne.answer%age) call abort
! KIND=4 test
  write (str4, *) chairman
  if (trim(str4).ne.4_"  Charlie                       62") call abort
  chairman%name="Bogus"
  chairman%age=99
  read (str4, *) chairman
  if (chairman%name.ne.answer%name) call abort
  if (chairman%age.ne.answer%age) call abort
END PROGRAM test