-/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2024 Free Software Foundation, Inc.
Contributed by Andy Vaught
+ F2003 I/O support contributed by Jerry DeLisle
-This file is part of the GNU Fortran 95 runtime library (libgfortran).
+This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
any later version.
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file. (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
-
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-You should have received a copy of the GNU General Public License
-along with Libgfortran; see the file COPYING. If not, write to
-the Free Software Foundation, 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
-#include "config.h"
-#include <stdlib.h>
-#include <string.h>
-#include "libgfortran.h"
#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include "async.h"
+#include <string.h>
+#include <assert.h>
/* IO locking rules:
- UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
+ UNIT_RWLOCK is a master rw lock, protecting UNIT_ROOT tree and UNIT_CACHE.
+ Using an rwlock improves efficiency by allowing us to separate readers
+ and writers of both UNIT_ROOT and UNIT_CACHE.
Concurrent use of different units should be supported, so
each unit has its own lock, LOCK.
Open should be atomic with its reopening of units and list_read.c
in several places needs find_unit another unit while holding stdin
- unit's lock, so it must be possible to acquire UNIT_LOCK while holding
+ unit's lock, so it must be possible to acquire UNIT_RWLOCK while holding
some unit's lock. Therefore to avoid deadlocks, it is forbidden
- to acquire unit's private locks while holding UNIT_LOCK, except
+ to acquire unit's private locks while holding UNIT_RWLOCK, except
for freshly created units (where no other thread can get at their
address yet) or when using just trylock rather than lock operation.
In addition to unit's private lock each unit has a WAITERS counter
and CLOSED flag. WAITERS counter must be either only
atomically incremented/decremented in all places (if atomic builtins
- are supported), or protected by UNIT_LOCK in all places (otherwise).
+ are supported), or protected by UNIT_RWLOCK in all places (otherwise).
CLOSED flag must be always protected by unit's LOCK.
- After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
+ After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_RWLOCK held,
WAITERS must be incremented to avoid concurrent close from freeing
- the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
- Unit freeing is always done under UNIT_LOCK. If close_unit sees any
+ the unit between unlocking UNIT_RWLOCK and acquiring unit's LOCK.
+ Unit freeing is always done under UNIT_RWLOCK. If close_unit sees any
WAITERS, it doesn't free the unit but instead sets the CLOSED flag
and the thread that decrements WAITERS to zero while CLOSED flag is
- set is responsible for freeing it (while holding UNIT_LOCK).
+ set is responsible for freeing it (while holding UNIT_RWLOCK).
flush_all_units operation is iterating over the unit tree with
- increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
+ increasing UNIT_NUMBER while holding UNIT_RWLOCK and attempting to
flush each unit (and therefore needs the unit's LOCK held as well).
To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
- remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
- unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
+ remembers the current unit's UNIT_NUMBER, unlocks UNIT_RWLOCK, acquires
+ unit's LOCK and after flushing reacquires UNIT_RWLOCK and restarts with
the smallest UNIT_NUMBER above the last one flushed.
If find_unit/find_or_create_unit/find_file/get_unit routines return
on it. unlock_unit or close_unit must be always called only with the
private lock held. */
-/* Subroutines related to units */
+/* 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];
+
gfc_offset max_offset;
+gfc_offset default_recl;
+
gfc_unit *unit_root;
+#ifdef __GTHREAD_RWLOCK_INIT
+__gthread_rwlock_t unit_rwlock = __GTHREAD_RWLOCK_INIT;
+#else
+#ifdef __GTHREAD_MUTEX_INIT
+__gthread_mutex_t unit_rwlock = __GTHREAD_MUTEX_INIT;
+#else
+__gthread_mutex_t unit_rwlock;
+#endif
+#endif
+
+/* We use these filenames for error reporting. */
+
+static char stdin_name[] = "stdin";
+static char stdout_name[] = "stdout";
+static char stderr_name[] = "stderr";
+
+
+#ifdef HAVE_POSIX_2008_LOCALE
+locale_t c_locale;
+#else
+/* If we don't have POSIX 2008 per-thread locales, we need to use the
+ traditional setlocale(). To prevent multiple concurrent threads
+ doing formatted I/O from messing up the locale, we need to store a
+ global old_locale, and a counter keeping track of how many threads
+ are currently doing formatted I/O. The first thread saves the old
+ locale, and the last one restores it. */
+char *old_locale;
+int old_locale_ctr;
#ifdef __GTHREAD_MUTEX_INIT
-__gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
+__gthread_mutex_t old_locale_lock = __GTHREAD_MUTEX_INIT;
#else
-__gthread_mutex_t unit_lock;
+__gthread_mutex_t old_locale_lock;
+#endif
#endif
+
/* 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;
}
-
static int
compare (int a, int b)
{
static gfc_unit *
insert_unit (int n)
{
- gfc_unit *u = get_mem (sizeof (gfc_unit));
- memset (u, '\0', sizeof (gfc_unit));
+ gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
u->unit_number = n;
+ u->internal_unit_kind = 0;
#ifdef __GTHREAD_MUTEX_INIT
{
__gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
#else
__GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
#endif
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
u->priority = pseudo_random ();
unit_root = insert (u, unit_root);
return u;
}
+/* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
+
+static void
+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_gfc_unit_from_root()-- Given an integer, return a pointer
+ to the unit structure. Returns NULL if the unit does not exist,
+ otherwise returns a locked unit. */
-/* 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. */
+static inline gfc_unit *
+get_gfc_unit_from_unit_root (int n)
+{
+ gfc_unit *p;
+ int c = 0;
+ p = unit_root;
+ while (p != NULL)
+ {
+ c = compare (n, p->unit_number);
+ if (c < 0)
+ p = p->left;
+ if (c > 0)
+ p = p->right;
+ if (c == 0)
+ break;
+ }
+ return p;
+}
+
+/* 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;
- __gthread_mutex_lock (&unit_lock);
+ NOTE ("Unit n=%d, do_create = %d", n, do_create);
+ RDLOCK (&unit_rwlock);
+
retry:
for (c = 0; c < CACHE_SIZE; c++)
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
goto found;
}
- p = unit_root;
- while (p != NULL)
- {
- c = compare (n, p->unit_number);
- if (c < 0)
- p = p->left;
- if (c > 0)
- p = p->right;
- if (c == 0)
- break;
- }
-
+ p = get_gfc_unit_from_unit_root (n);
+
+ /* We did not find a unit in the cache nor in the unit list,
+ create a new (locked) unit and insert into the unit list and
+ cache. Manipulating either or both the unit list and the unit
+ cache requires to hold a write-lock [for obvious reasons]:
+ By separating the read/write lock, we will greatly reduce
+ the contention on the read part, while the write part is
+ unlikely once the unit hits the cache. */
+ RD_TO_WRLOCK (&unit_rwlock);
+
+ /* In the case of high concurrency, when multiple threads want
+ to find or create the same unit, the unit number may not
+ exist in cache nor in the unit list during read phase, then
+ threads will acquire the write-lock to insert the same unit
+ number to unit list. To avoid duplicate insert, we need to
+ find unit list once again to ensure that the unit number
+ not exist. */
+ p = get_gfc_unit_from_unit_root (n);
if (p == NULL && do_create)
{
p = insert_unit (n);
if (created)
{
/* Newly created units have their lock held already
- from insert_unit. Just unlock UNIT_LOCK and return. */
- __gthread_mutex_unlock (&unit_lock);
+ from insert_unit. Just unlock UNIT_RWLOCK and return. */
+ RWUNLOCK (&unit_rwlock);
return p;
}
found:
- if (p != NULL)
+ if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
- if (! __gthread_mutex_trylock (&p->lock))
+ if (! TRYLOCK (&p->lock))
{
/* assert (p->closed == 0); */
- __gthread_mutex_unlock (&unit_lock);
+ RWUNLOCK (&unit_rwlock);
return p;
}
inc_waiting_locked (p);
}
- __gthread_mutex_unlock (&unit_lock);
- if (p != NULL)
+ RWUNLOCK (&unit_rwlock);
+
+ if (p != NULL && (p->child_dtio == 0))
{
- __gthread_mutex_lock (&p->lock);
+ LOCK (&p->lock);
if (p->closed)
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&p->lock);
+ WRLOCK (&unit_rwlock);
+ UNLOCK (&p->lock);
if (predec_waiting_locked (p) == 0)
- free_mem (p);
+ destroy_unit_mutex (p);
goto retry;
}
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)
+/* Helper function to check rank, stride, format string, and namelist.
+ This is used for optimization. You can't trim out blanks or shorten
+ the string if trailing spaces are significant. */
+static bool
+is_trim_ok (st_parameter_dt *dtp)
{
- gfc_unit * iunit;
-
- /* Allocate memory for a unit structure. */
-
- iunit = get_mem (sizeof (gfc_unit));
- if (iunit == NULL)
+ /* Check rank and stride. */
+ if (dtp->internal_unit_desc)
+ return false;
+ /* Format strings cannot have 'BZ' or '/'. */
+ if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
{
- generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
- return NULL;
+ char *p = dtp->format;
+ if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
+ return false;
+ for (gfc_charlen_type i = 0; i < dtp->format_len; i++)
+ {
+ if (p[i] == '/') return false;
+ if (p[i] == 'b' || p[i] == 'B')
+ if (p[i+1] == 'z' || p[i+1] == 'Z')
+ return false;
+ }
}
+ if (dtp->u.p.ionml) /* A namelist. */
+ return false;
+ return true;
+}
- memset (iunit, '\0', 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);
+
+gfc_unit *
+set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
+{
+ gfc_offset start_record = 0;
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
+ where trailing blanks have significance. */
+ if (dtp->u.p.mode == READING && is_trim_ok (dtp))
+ {
+ int len;
+ if (kind == 1)
+ len = string_len_trim (iunit->internal_unit_len,
+ iunit->internal_unit);
+ else
+ 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 *)
- get_mem (iunit->rank * sizeof (array_loop_spec));
- dtp->internal_unit_len *=
- init_loop_spec (dtp->internal_unit_desc, iunit->ls);
+ xmallocarray (iunit->rank, sizeof (array_loop_spec));
+ 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 (kind == 4)
+ iunit->s = open_internal4 (iunit->internal_unit - start_record,
+ iunit->internal_unit_len, -start_record);
+ else
+ iunit->s = open_internal (iunit->internal_unit - start_record,
+ iunit->internal_unit_len, -start_record);
- iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len);
iunit->bytes_left = iunit->recl;
iunit->last_record=0;
iunit->maxrec=0;
iunit->current_record=0;
iunit->read_bad = 0;
+ iunit->endfile = NO_ENDFILE;
+ iunit->last_char = 0;
/* Set flags for the internal unit. */
iunit->flags.access = ACCESS_SEQUENTIAL;
iunit->flags.action = ACTION_READWRITE;
+ iunit->flags.blank = BLANK_NULL;
iunit->flags.form = FORM_FORMATTED;
iunit->flags.pad = PAD_YES;
iunit->flags.status = STATUS_UNSPECIFIED;
- iunit->endfile = NO_ENDFILE;
+ iunit->flags.sign = SIGN_PROCDEFINED;
+ iunit->flags.decimal = DECIMAL_POINT;
+ iunit->flags.delim = DELIM_UNSPECIFIED;
+ iunit->flags.encoding = ENCODING_DEFAULT;
+ iunit->flags.async = ASYNC_NO;
+ iunit->flags.round = ROUND_PROCDEFINED;
/* Initialize the data transfer parameters. */
dtp->u.p.advance_status = ADVANCE_YES;
- dtp->u.p.blank_status = BLANK_UNSPECIFIED;
dtp->u.p.seen_dollar = 0;
dtp->u.p.skips = 0;
dtp->u.p.pending_spaces = 0;
dtp->u.p.max_pos = 0;
-
- /* This flag tells us the unit is assigned to internal I/O. */
-
- dtp->u.p.unit_is_internal = 1;
-
+ dtp->u.p.at_eof = 0;
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 (dtp->u.p.current_unit->ls != NULL)
- free_mem (dtp->u.p.current_unit->ls);
-
- sclose (dtp->u.p.current_unit->s);
-
- if (dtp->u.p.current_unit != NULL)
- free_mem (dtp->u.p.current_unit);
-}
-
-
/* get_unit()-- Returns the unit structure associated with the integer
- * unit or the internal file. */
+ 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);
-
- /* Has to be an external unit */
+ {
+ 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);
-}
-
-
-/* is_internal_unit()-- Determine if the current unit is internal or not */
-
-int
-is_internal_unit (st_parameter_dt *dtp)
-{
- return dtp->u.p.unit_is_internal;
-}
-
-
-/* is_array_io ()-- Determine if the I/O is to/from an array */
+ /* 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)
+ {
+ if (dtp->common.unit > NEWUNIT_START) /* Reserved units. */
+ return NULL;
+ return get_gfc_unit (dtp->common.unit, 0);
+ }
-int
-is_array_io (st_parameter_dt *dtp)
-{
- return dtp->internal_unit_desc != NULL;
+ return get_gfc_unit (dtp->common.unit, do_create);
}
/*************************/
-/* Initialize everything */
+/* Initialize everything. */
void
init_units (void)
{
gfc_unit *u;
- unsigned int i;
+#ifdef HAVE_POSIX_2008_LOCALE
+ c_locale = newlocale (0, "C", 0);
+#else
#ifndef __GTHREAD_MUTEX_INIT
- __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
+ __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
+#endif
+#endif
+
+#if (!defined(__GTHREAD_RWLOCK_INIT) && !defined(__GTHREAD_MUTEX_INIT))
+ __GTHREAD_MUTEX_INIT_FUNCTION (&unit_rwlock);
#endif
+ if (sizeof (max_offset) == 8)
+ {
+ max_offset = GFC_INTEGER_8_HUGE;
+ /* Why this weird value? Because if the recl specifier in the
+ inquire statement is a 4 byte value, u->recl is truncated,
+ and this trick ensures it becomes HUGE(0) rather than -1.
+ The full 8 byte value of default_recl is still 0.99999999 *
+ max_offset which is large enough for all practical
+ purposes. */
+ default_recl = max_offset & ~(1LL<<31);
+ }
+ else if (sizeof (max_offset) == 4)
+ max_offset = default_recl = GFC_INTEGER_4_HUGE;
+ else
+ internal_error (NULL, "sizeof (max_offset) must be 4 or 8");
+
if (options.stdin_unit >= 0)
{ /* STDIN */
u = insert_unit (options.stdin_unit);
u->flags.blank = BLANK_NULL;
u->flags.pad = PAD_YES;
u->flags.position = POSITION_ASIS;
-
- u->recl = options.default_recl;
+ u->flags.sign = SIGN_PROCDEFINED;
+ u->flags.decimal = DECIMAL_POINT;
+ u->flags.delim = DELIM_UNSPECIFIED;
+ u->flags.encoding = ENCODING_DEFAULT;
+ u->flags.async = ASYNC_NO;
+ u->flags.round = ROUND_PROCDEFINED;
+ u->flags.share = SHARE_UNSPECIFIED;
+ u->flags.cc = CC_LIST;
+
+ u->recl = default_recl;
u->endfile = NO_ENDFILE;
- __gthread_mutex_unlock (&u->lock);
+ u->filename = strdup (stdin_name);
+
+ fbuf_init (u, 0);
+
+ UNLOCK (&u->lock);
}
if (options.stdout_unit >= 0)
u->flags.status = STATUS_OLD;
u->flags.blank = BLANK_NULL;
u->flags.position = POSITION_ASIS;
-
- u->recl = options.default_recl;
+ u->flags.sign = SIGN_PROCDEFINED;
+ u->flags.decimal = DECIMAL_POINT;
+ u->flags.delim = DELIM_UNSPECIFIED;
+ u->flags.encoding = ENCODING_DEFAULT;
+ u->flags.async = ASYNC_NO;
+ u->flags.round = ROUND_PROCDEFINED;
+ u->flags.share = SHARE_UNSPECIFIED;
+ u->flags.cc = CC_LIST;
+
+ u->recl = default_recl;
u->endfile = AT_ENDFILE;
- __gthread_mutex_unlock (&u->lock);
+ u->filename = strdup (stdout_name);
+
+ fbuf_init (u, 0);
+
+ UNLOCK (&u->lock);
}
if (options.stderr_unit >= 0)
u->flags.status = STATUS_OLD;
u->flags.blank = BLANK_NULL;
u->flags.position = POSITION_ASIS;
-
- u->recl = options.default_recl;
+ u->flags.sign = SIGN_PROCDEFINED;
+ u->flags.decimal = DECIMAL_POINT;
+ u->flags.encoding = ENCODING_DEFAULT;
+ u->flags.async = ASYNC_NO;
+ u->flags.round = ROUND_PROCDEFINED;
+ u->flags.share = SHARE_UNSPECIFIED;
+ u->flags.cc = CC_LIST;
+
+ u->recl = default_recl;
u->endfile = AT_ENDFILE;
- __gthread_mutex_unlock (&u->lock);
- }
+ u->filename = strdup (stderr_name);
- /* Calculate the maximum file offset in a portable manner.
- * max will be the largest signed number for the type gfc_offset.
- *
- * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
+ fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
+ any kind of exotic formatting to stderr. */
- max_offset = 0;
- for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
- max_offset = max_offset + ((gfc_offset) 1 << i);
+ UNLOCK (&u->lock);
+ }
+ /* The default internal units. */
+ u = insert_unit (GFC_INTERNAL_UNIT);
+ UNLOCK (&u->lock);
+ u = insert_unit (GFC_INTERNAL_UNIT4);
+ UNLOCK (&u->lock);
}
{
int i, rc;
- rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
+ if (ASYNC_IO && u->au)
+ async_close (u->au);
+
+ /* If there are previously written bytes from a write with ADVANCE="no"
+ Reposition the buffer before closing. */
+ if (u->previous_nonadvancing_write)
+ finish_last_advance_record (u);
+
+ rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
u->closed = 1;
if (!locked)
- __gthread_mutex_lock (&unit_lock);
+ WRLOCK (&unit_rwlock);
for (i = 0; i < CACHE_SIZE; i++)
if (unit_cache[i] == u)
delete_unit (u);
- if (u->file)
- free_mem (u->file);
- u->file = NULL;
- u->file_len = 0;
+ free (u->filename);
+ u->filename = NULL;
+
+ 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);
+ UNLOCK (&u->lock);
/* If there are any threads waiting in find_unit for this unit,
avoid freeing the memory, the last such thread will free it
instead. */
if (u->waiting == 0)
- free_mem (u);
+ destroy_unit_mutex (u);
if (!locked)
- __gthread_mutex_unlock (&unit_lock);
+ RWUNLOCK (&unit_rwlock);
return rc;
}
void
unlock_unit (gfc_unit *u)
{
- __gthread_mutex_unlock (&u->lock);
+ if (u)
+ {
+ NOTE ("unlock_unit = %d", u->unit_number);
+ UNLOCK (&u->lock);
+ NOTE ("unlock_unit done");
+ }
}
/* close_unit()-- Close a unit. The stream is closed, and any memory
- * associated with the stream is freed. Returns nonzero on I/O error.
- * Should be called with the u->lock locked. */
+ associated with the stream is freed. Returns nonzero on I/O error.
+ Should be called with the u->lock locked. */
int
close_unit (gfc_unit *u)
/* close_units()-- Delete units on completion. We just keep deleting
- * the root of the treap until there is nothing left.
- * Not sure what to do with locking here. Some other thread might be
- * holding some unit's lock and perhaps hold it indefinitely
- * (e.g. waiting for input from some pipe) and close_units shouldn't
- * delay the program too much. */
+ the root of the treap until there is nothing left.
+ Not sure what to do with locking here. Some other thread might be
+ holding some unit's lock and perhaps hold it indefinitely
+ (e.g. waiting for input from some pipe) and close_units shouldn't
+ delay the program too much. */
void
close_units (void)
{
- __gthread_mutex_lock (&unit_lock);
+ WRLOCK (&unit_rwlock);
while (unit_root != NULL)
close_unit_1 (unit_root, 1);
- __gthread_mutex_unlock (&unit_lock);
+ RWUNLOCK (&unit_rwlock);
+
+ free (newunits);
+
+#ifdef HAVE_POSIX_2008_LOCALE
+ freelocale (c_locale);
+#endif
+}
+
+
+/* High level interface to truncate a file, i.e. flush format buffers,
+ and generate an error or set some flags. Just like POSIX
+ ftruncate, returns 0 on success, -1 on failure. */
+
+int
+unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
+{
+ int ret;
+
+ /* Make sure format buffer is flushed. */
+ if (u->flags.form == FORM_FORMATTED)
+ {
+ if (u->mode == READING)
+ pos += fbuf_reset (u);
+ else
+ fbuf_flush (u, u->mode);
+ }
+
+ /* struncate() should flush the stream buffer if necessary, so don't
+ bother calling sflush() here. */
+ ret = struncate (u->s, pos);
+
+ if (ret != 0)
+ generate_error (common, LIBERROR_OS, NULL);
+ else
+ {
+ u->endfile = AT_ENDFILE;
+ u->flags.position = POSITION_APPEND;
+ }
+
+ return ret;
+}
+
+
+/* filename_from_unit()-- If the unit_number exists, return a pointer to the
+ name of the associated file, otherwise return the empty string. The caller
+ must free memory allocated for the filename string. */
+
+char *
+filename_from_unit (int n)
+{
+ gfc_unit *u;
+ int c;
+
+ /* Find the unit. */
+ u = unit_root;
+ while (u != NULL)
+ {
+ c = compare (n, u->unit_number);
+ if (c < 0)
+ u = u->left;
+ if (c > 0)
+ u = u->right;
+ if (c == 0)
+ break;
+ }
+
+ /* Get the filename. */
+ if (u != NULL && u->filename != NULL)
+ return strdup (u->filename);
+ else
+ return (char *) NULL;
+}
+
+void
+finish_last_advance_record (gfc_unit *u)
+{
+
+ if (u->saved_pos > 0)
+ fbuf_seek (u, u->saved_pos, SEEK_CUR);
+
+ if (!(u->unit_number == options.stdout_unit
+ || u->unit_number == options.stderr_unit))
+ {
+#ifdef HAVE_CRLF
+ const int len = 2;
+#else
+ const int len = 1;
+#endif
+ char *p = fbuf_alloc (u, len);
+ if (!p)
+ os_error ("Completing record after ADVANCE_NO failed");
+#ifdef HAVE_CRLF
+ *(p++) = '\r';
+#endif
+ *p = '\n';
+ }
+
+ fbuf_flush (u, u->mode);
+}
+
+
+/* Assign a negative number for NEWUNIT in OPEN statements or for
+ internal units. */
+int
+newunit_alloc (void)
+{
+ WRLOCK (&unit_rwlock);
+ if (!newunits)
+ {
+ newunits = xcalloc (16, 1);
+ newunit_size = 16;
+ }
+
+ /* Search for the next available newunit. */
+ for (int ii = newunit_lwi; ii < newunit_size; ii++)
+ {
+ if (!newunits[ii])
+ {
+ newunits[ii] = true;
+ newunit_lwi = ii + 1;
+ RWUNLOCK (&unit_rwlock);
+ return -ii + NEWUNIT_START;
+ }
+ }
+
+ /* 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;
+ RWUNLOCK (&unit_rwlock);
+ return -old_size + NEWUNIT_START;
+}
+
+
+/* Free a previously allocated newunit= unit number. unit_rwlock 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 / thirdparty / gcc.git / blobdiff