X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=libgfortran%2Fio%2Funit.c;h=e62f9b839d4a35eff4e251459082807a8ff8bff5;hb=8c098567886e155a07aabfeea764d5c67eadbdaf;hp=fde9ac752d42cdc295ee55d173882909d0d76c2d;hpb=e73d3ca6d1caf9c1187eeb1236dffd42f15ec043;p=gcc.git

diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index fde9ac752d4..e62f9b839d4 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002-2016 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2017 Free Software Foundation, Inc.
    Contributed by Andy Vaught
    F2003 I/O support contributed by Jerry DeLisle
 
@@ -27,8 +27,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include "fbuf.h"
 #include "format.h"
 #include "unix.h"
-#include <stdlib.h>
 #include <string.h>
+#include <assert.h>
 
 
 /* IO locking rules:
@@ -68,11 +68,30 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
    on it.  unlock_unit or close_unit must be always called only with the
    private lock held.  */
 
-/* Subroutines related to units */
 
-/* Unit number to be assigned when NEWUNIT is used in an OPEN statement.  */
-#define GFC_FIRST_NEWUNIT -10
-static GFC_INTEGER_4 next_available_newunit = GFC_FIRST_NEWUNIT;
+
+/* Table of allocated newunit values.  A simple solution would be to
+   map OS file descriptors (fd's) to unit numbers, e.g. with newunit =
+   -fd - 2, however that doesn't work since Fortran allows an existing
+   unit number to be reassociated with a new file. Thus the simple
+   approach may lead to a situation where we'd try to assign a
+   (negative) unit number which already exists. Hence we must keep
+   track of allocated newunit values ourselves. This is the purpose of
+   the newunits array. The indices map to newunit values as newunit =
+   -index + NEWUNIT_FIRST. E.g. newunits[0] having the value true
+   means that a unit with number NEWUNIT_FIRST exists. Similar to
+   POSIX file descriptors, we always allocate the lowest (in absolute
+   value) available unit number.
+ */
+static bool *newunits;
+static int newunit_size; /* Total number of elements in the newunits array.  */
+/* Low water indicator for the newunits array. Below the LWI all the
+   units are allocated, above and equal to the LWI there may be both
+   allocated and free units. */
+static int newunit_lwi;
+
+/* Unit numbers assigned with NEWUNIT start from here.  */
+#define NEWUNIT_START -10
 
 #define CACHE_SIZE 3
 static gfc_unit *unit_cache[CACHE_SIZE];
@@ -111,11 +130,11 @@ __gthread_mutex_t old_locale_lock;
 
 
 /* This implementation is based on Stefan Nilsson's article in the
- * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
+   July 1997 Doctor Dobb's Journal, "Treaps in Java". */
 
 /* pseudo_random()-- Simple linear congruential pseudorandom number
- * generator.  The period of this generator is 44071, which is plenty
- * for our purposes.  */
+   generator.  The period of this generator is 44071, which is plenty
+   for our purposes.  */
 
 static int
 pseudo_random (void)
@@ -130,7 +149,7 @@ pseudo_random (void)
 /* rotate_left()-- Rotate the treap left */
 
 static gfc_unit *
-rotate_left (gfc_unit * t)
+rotate_left (gfc_unit *t)
 {
   gfc_unit *temp;
 
@@ -145,7 +164,7 @@ rotate_left (gfc_unit * t)
 /* rotate_right()-- Rotate the treap right */
 
 static gfc_unit *
-rotate_right (gfc_unit * t)
+rotate_right (gfc_unit *t)
 {
   gfc_unit *temp;
 
@@ -227,7 +246,7 @@ insert_unit (int n)
 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit.  */
 
 static void
-destroy_unit_mutex (gfc_unit * u)
+destroy_unit_mutex (gfc_unit *u)
 {
   __gthread_mutex_destroy (&u->lock);
   free (u);
@@ -235,7 +254,7 @@ destroy_unit_mutex (gfc_unit * u)
 
 
 static gfc_unit *
-delete_root (gfc_unit * t)
+delete_root (gfc_unit *t)
 {
   gfc_unit *temp;
 
@@ -260,12 +279,12 @@ delete_root (gfc_unit * t)
 
 
 /* delete_treap()-- Delete an element from a tree.  The 'old' value
- * does not necessarily have to point to the element to be deleted, it
- * must just point to a treap structure with the key to be deleted.
- * Returns the new root node of the tree. */
+   does not necessarily have to point to the element to be deleted, it
+   must just point to a treap structure with the key to be deleted.
+   Returns the new root node of the tree. */
 
 static gfc_unit *
-delete_treap (gfc_unit * old, gfc_unit * t)
+delete_treap (gfc_unit *old, gfc_unit *t)
 {
   int c;
 
@@ -288,18 +307,18 @@ delete_treap (gfc_unit * old, gfc_unit * t)
 /* delete_unit()-- Delete a unit from a tree */
 
 static void
-delete_unit (gfc_unit * old)
+delete_unit (gfc_unit *old)
 {
   unit_root = delete_treap (old, unit_root);
 }
 
 
-/* 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. */
+/* 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 +380,7 @@ found:
       inc_waiting_locked (p);
     }
 
+
   __gthread_mutex_unlock (&unit_lock);
 
   if (p != NULL && (p->child_dtio == 0))
@@ -384,14 +404,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 +446,15 @@ 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->unit_number = dtp->common.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;
+  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 +462,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 +479,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,53 +523,48 @@ 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.  */
-void
-free_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);
-    }
-}
-
-
-
 /* 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)
 {
+  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 = newunit_alloc ();
+      unit = get_gfc_unit (dtp->common.unit, do_create);
+      set_internal_unit (dtp, unit, kind);
+      fbuf_init (unit, 128);
+      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);
+  /* For an external unit with unit number < 0 creating it on the fly
+     is not allowed, such units must be created with
+     OPEN(NEWUNIT=...).  */
+  if (dtp->common.unit < 0)
+    return get_gfc_unit (dtp->common.unit, 0);
+
+  return get_gfc_unit (dtp->common.unit, do_create);
 }
 
 
@@ -612,6 +608,8 @@ init_units (void)
       u->flags.encoding = ENCODING_DEFAULT;
       u->flags.async = ASYNC_NO;
       u->flags.round = ROUND_UNSPECIFIED;
+      u->flags.share = SHARE_UNSPECIFIED;
+      u->flags.cc = CC_LIST;
 
       u->recl = options.default_recl;
       u->endfile = NO_ENDFILE;
@@ -641,6 +639,8 @@ init_units (void)
       u->flags.encoding = ENCODING_DEFAULT;
       u->flags.async = ASYNC_NO;
       u->flags.round = ROUND_UNSPECIFIED;
+      u->flags.share = SHARE_UNSPECIFIED;
+      u->flags.cc = CC_LIST;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
@@ -669,6 +669,8 @@ init_units (void)
       u->flags.encoding = ENCODING_DEFAULT;
       u->flags.async = ASYNC_NO;
       u->flags.round = ROUND_UNSPECIFIED;
+      u->flags.share = SHARE_UNSPECIFIED;
+      u->flags.cc = CC_LIST;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
@@ -718,6 +720,9 @@ close_unit_1 (gfc_unit *u, int locked)
   free_format_hash_table (u);
   fbuf_destroy (u);
 
+  if (u->unit_number <= NEWUNIT_START)
+    newunit_free (u->unit_number);
+
   if (!locked)
     __gthread_mutex_unlock (&u->lock);
 
@@ -765,6 +770,8 @@ close_units (void)
     close_unit_1 (unit_root, 1);
   __gthread_mutex_unlock (&unit_lock);
 
+  free (newunits);
+
 #ifdef HAVE_FREELOCALE
   freelocale (c_locale);
 #endif
@@ -776,7 +783,7 @@ close_units (void)
    ftruncate, returns 0 on success, -1 on failure.  */
 
 int
-unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
+unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
 {
   int ret;
 
@@ -862,25 +869,53 @@ finish_last_advance_record (gfc_unit *u)
   fbuf_flush (u, u->mode);
 }
 
-/* Assign a negative number for NEWUNIT in OPEN statements.  */
-GFC_INTEGER_4
-get_unique_unit_number (st_parameter_open *opp)
-{
-  GFC_INTEGER_4 num;
 
-#ifdef HAVE_SYNC_FETCH_AND_ADD
-  num = __sync_fetch_and_add (&next_available_newunit, -1);
-#else
+/* Assign a negative number for NEWUNIT in OPEN statements or for
+   internal units.  */
+int
+newunit_alloc (void)
+{
   __gthread_mutex_lock (&unit_lock);
-  num = next_available_newunit--;
-  __gthread_mutex_unlock (&unit_lock);
-#endif
+  if (!newunits)
+    {
+      newunits = xcalloc (16, 1);
+      newunit_size = 16;
+    }
 
-  /* Do not allow NEWUNIT numbers to wrap.  */
-  if (num > GFC_FIRST_NEWUNIT)
+  /* Search for the next available newunit.  */
+  for (int ii = newunit_lwi; ii < newunit_size; ii++)
     {
-      generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
-      return 0;
+      if (!newunits[ii])
+        {
+          newunits[ii] = true;
+          newunit_lwi = ii + 1;
+	  __gthread_mutex_unlock (&unit_lock);
+          return -ii + NEWUNIT_START;
+        }
     }
-  return num;
+
+  /* Search failed, bump size of array and allocate the first
+     available unit.  */
+  int old_size = newunit_size;
+  newunit_size *= 2;
+  newunits = xrealloc (newunits, newunit_size);
+  memset (newunits + old_size, 0, old_size);
+  newunits[old_size] = true;
+  newunit_lwi = old_size + 1;
+    __gthread_mutex_unlock (&unit_lock);
+  return -old_size + NEWUNIT_START;
+}
+
+
+/* Free a previously allocated newunit= unit number.  unit_lock must
+   be held when calling.  */
+
+void
+newunit_free (int unit)
+{
+  int ind = -unit + NEWUNIT_START;
+  assert(ind >= 0 && ind < newunit_size);
+  newunits[ind] = false;
+  if (ind < newunit_lwi)
+    newunit_lwi = ind;
 }