-/* 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
#include "fbuf.h"
#include "format.h"
#include "unix.h"
-#include <stdlib.h>
#include <string.h>
+#include <assert.h>
/* IO locking rules:
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];
/* 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)
/* rotate_left()-- Rotate the treap left */
static gfc_unit *
-rotate_left (gfc_unit * t)
+rotate_left (gfc_unit *t)
{
gfc_unit *temp;
/* rotate_right()-- Rotate the treap right */
static gfc_unit *
-rotate_right (gfc_unit * t)
+rotate_right (gfc_unit *t)
{
gfc_unit *temp;
/* 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);
static gfc_unit *
-delete_root (gfc_unit * t)
+delete_root (gfc_unit *t)
{
gfc_unit *temp;
/* 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;
/* 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;
inc_waiting_locked (p);
}
+
__gthread_mutex_unlock (&unit_lock);
if (p != NULL && (p->child_dtio == 0))
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);
}
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
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. */
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;
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);
}
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;
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;
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;
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);
close_unit_1 (unit_root, 1);
__gthread_mutex_unlock (&unit_lock);
+ free (newunits);
+
#ifdef HAVE_FREELOCALE
freelocale (c_locale);
#endif
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;
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;
}
projects / gcc.git / blobdiff