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

1 files changed, 93 insertions, 70 deletions

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;