952 lines
24 KiB
C
952 lines
24 KiB
C
/* Copyright (C) 2002-2022 Free Software Foundation, Inc.
|
|
Contributed by Andy Vaught
|
|
F2003 I/O support contributed by Jerry DeLisle
|
|
|
|
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 3, or (at your option)
|
|
any later version.
|
|
|
|
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.
|
|
|
|
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 "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.
|
|
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
|
|
some unit's lock. Therefore to avoid deadlocks, it is forbidden
|
|
to acquire unit's private locks while holding UNIT_LOCK, 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).
|
|
CLOSED flag must be always protected by unit's LOCK.
|
|
After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK 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
|
|
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).
|
|
flush_all_units operation is iterating over the unit tree with
|
|
increasing UNIT_NUMBER while holding UNIT_LOCK 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
|
|
the smallest UNIT_NUMBER above the last one flushed.
|
|
|
|
If find_unit/find_or_create_unit/find_file/get_unit routines return
|
|
non-NULL, the returned unit has its private lock locked and when the
|
|
caller is done with it, it must call either unlock_unit or close_unit
|
|
on it. unlock_unit or close_unit must be always called only with the
|
|
private lock held. */
|
|
|
|
|
|
|
|
/* 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_MUTEX_INIT
|
|
__gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
|
|
#else
|
|
__gthread_mutex_t unit_lock;
|
|
#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 old_locale_lock = __GTHREAD_MUTEX_INIT;
|
|
#else
|
|
__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". */
|
|
|
|
/* pseudo_random()-- Simple linear congruential pseudorandom number
|
|
generator. The period of this generator is 44071, which is plenty
|
|
for our purposes. */
|
|
|
|
static int
|
|
pseudo_random (void)
|
|
{
|
|
static int x0 = 5341;
|
|
|
|
x0 = (22611 * x0 + 10) % 44071;
|
|
return x0;
|
|
}
|
|
|
|
|
|
/* rotate_left()-- Rotate the treap left */
|
|
|
|
static gfc_unit *
|
|
rotate_left (gfc_unit *t)
|
|
{
|
|
gfc_unit *temp;
|
|
|
|
temp = t->right;
|
|
t->right = t->right->left;
|
|
temp->left = t;
|
|
|
|
return temp;
|
|
}
|
|
|
|
|
|
/* rotate_right()-- Rotate the treap right */
|
|
|
|
static gfc_unit *
|
|
rotate_right (gfc_unit *t)
|
|
{
|
|
gfc_unit *temp;
|
|
|
|
temp = t->left;
|
|
t->left = t->left->right;
|
|
temp->right = t;
|
|
|
|
return temp;
|
|
}
|
|
|
|
|
|
static int
|
|
compare (int a, int b)
|
|
{
|
|
if (a < b)
|
|
return -1;
|
|
if (a > b)
|
|
return 1;
|
|
|
|
return 0;
|
|
}
|
|
|
|
|
|
/* insert()-- Recursive insertion function. Returns the updated treap. */
|
|
|
|
static gfc_unit *
|
|
insert (gfc_unit *new, gfc_unit *t)
|
|
{
|
|
int c;
|
|
|
|
if (t == NULL)
|
|
return new;
|
|
|
|
c = compare (new->unit_number, t->unit_number);
|
|
|
|
if (c < 0)
|
|
{
|
|
t->left = insert (new, t->left);
|
|
if (t->priority < t->left->priority)
|
|
t = rotate_right (t);
|
|
}
|
|
|
|
if (c > 0)
|
|
{
|
|
t->right = insert (new, t->right);
|
|
if (t->priority < t->right->priority)
|
|
t = rotate_left (t);
|
|
}
|
|
|
|
if (c == 0)
|
|
internal_error (NULL, "insert(): Duplicate key found!");
|
|
|
|
return t;
|
|
}
|
|
|
|
|
|
/* insert_unit()-- Create a new node, insert it into the treap. */
|
|
|
|
static gfc_unit *
|
|
insert_unit (int n)
|
|
{
|
|
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;
|
|
u->lock = tmp;
|
|
}
|
|
#else
|
|
__GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
|
|
#endif
|
|
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)
|
|
{
|
|
gfc_unit *temp;
|
|
|
|
if (t->left == NULL)
|
|
return t->right;
|
|
if (t->right == NULL)
|
|
return t->left;
|
|
|
|
if (t->left->priority > t->right->priority)
|
|
{
|
|
temp = rotate_right (t);
|
|
temp->right = delete_root (t);
|
|
}
|
|
else
|
|
{
|
|
temp = rotate_left (t);
|
|
temp->left = delete_root (t);
|
|
}
|
|
|
|
return 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. */
|
|
|
|
static gfc_unit *
|
|
delete_treap (gfc_unit *old, gfc_unit *t)
|
|
{
|
|
int c;
|
|
|
|
if (t == NULL)
|
|
return NULL;
|
|
|
|
c = compare (old->unit_number, t->unit_number);
|
|
|
|
if (c < 0)
|
|
t->left = delete_treap (old, t->left);
|
|
if (c > 0)
|
|
t->right = delete_treap (old, t->right);
|
|
if (c == 0)
|
|
t = delete_root (t);
|
|
|
|
return t;
|
|
}
|
|
|
|
|
|
/* delete_unit()-- Delete a unit from a tree */
|
|
|
|
static void
|
|
delete_unit (gfc_unit *old)
|
|
{
|
|
unit_root = delete_treap (old, unit_root);
|
|
}
|
|
|
|
|
|
/* 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_gfc_unit (int n, int do_create)
|
|
{
|
|
gfc_unit *p;
|
|
int c, created = 0;
|
|
|
|
NOTE ("Unit n=%d, do_create = %d", n, do_create);
|
|
LOCK (&unit_lock);
|
|
|
|
retry:
|
|
for (c = 0; c < CACHE_SIZE; c++)
|
|
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
|
|
{
|
|
p = unit_cache[c];
|
|
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;
|
|
}
|
|
|
|
if (p == NULL && do_create)
|
|
{
|
|
p = insert_unit (n);
|
|
created = 1;
|
|
}
|
|
|
|
if (p != NULL)
|
|
{
|
|
for (c = 0; c < CACHE_SIZE - 1; c++)
|
|
unit_cache[c] = unit_cache[c + 1];
|
|
|
|
unit_cache[CACHE_SIZE - 1] = p;
|
|
}
|
|
|
|
if (created)
|
|
{
|
|
/* Newly created units have their lock held already
|
|
from insert_unit. Just unlock UNIT_LOCK and return. */
|
|
UNLOCK (&unit_lock);
|
|
return p;
|
|
}
|
|
|
|
found:
|
|
if (p != NULL && (p->child_dtio == 0))
|
|
{
|
|
/* Fast path. */
|
|
if (! TRYLOCK (&p->lock))
|
|
{
|
|
/* assert (p->closed == 0); */
|
|
UNLOCK (&unit_lock);
|
|
return p;
|
|
}
|
|
|
|
inc_waiting_locked (p);
|
|
}
|
|
|
|
|
|
UNLOCK (&unit_lock);
|
|
|
|
if (p != NULL && (p->child_dtio == 0))
|
|
{
|
|
LOCK (&p->lock);
|
|
if (p->closed)
|
|
{
|
|
LOCK (&unit_lock);
|
|
UNLOCK (&p->lock);
|
|
if (predec_waiting_locked (p) == 0)
|
|
destroy_unit_mutex (p);
|
|
goto retry;
|
|
}
|
|
|
|
dec_waiting_unlocked (p);
|
|
}
|
|
return p;
|
|
}
|
|
|
|
|
|
gfc_unit *
|
|
find_unit (int n)
|
|
{
|
|
return get_gfc_unit (n, 0);
|
|
}
|
|
|
|
|
|
gfc_unit *
|
|
find_or_create_unit (int n)
|
|
{
|
|
return get_gfc_unit (n, 1);
|
|
}
|
|
|
|
|
|
/* 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)
|
|
{
|
|
/* 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)
|
|
{
|
|
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;
|
|
}
|
|
|
|
|
|
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;
|
|
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. */
|
|
|
|
if (is_array_io (dtp))
|
|
{
|
|
iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
|
|
iunit->ls = (array_loop_spec *)
|
|
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->bytes_left = iunit->recl;
|
|
iunit->last_record=0;
|
|
iunit->maxrec=0;
|
|
iunit->current_record=0;
|
|
iunit->read_bad = 0;
|
|
iunit->endfile = NO_ENDFILE;
|
|
|
|
/* 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->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.seen_dollar = 0;
|
|
dtp->u.p.skips = 0;
|
|
dtp->u.p.pending_spaces = 0;
|
|
dtp->u.p.max_pos = 0;
|
|
dtp->u.p.at_eof = 0;
|
|
return iunit;
|
|
}
|
|
|
|
|
|
/* 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)
|
|
{
|
|
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;
|
|
|
|
/* 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);
|
|
}
|
|
|
|
return get_gfc_unit (dtp->common.unit, do_create);
|
|
}
|
|
|
|
|
|
/*************************/
|
|
/* Initialize everything. */
|
|
|
|
void
|
|
init_units (void)
|
|
{
|
|
gfc_unit *u;
|
|
|
|
#ifdef HAVE_POSIX_2008_LOCALE
|
|
c_locale = newlocale (0, "C", 0);
|
|
#else
|
|
#ifndef __GTHREAD_MUTEX_INIT
|
|
__GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
|
|
#endif
|
|
#endif
|
|
|
|
#ifndef __GTHREAD_MUTEX_INIT
|
|
__GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
|
|
#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->s = input_stream ();
|
|
|
|
u->flags.action = ACTION_READ;
|
|
|
|
u->flags.access = ACCESS_SEQUENTIAL;
|
|
u->flags.form = FORM_FORMATTED;
|
|
u->flags.status = STATUS_OLD;
|
|
u->flags.blank = BLANK_NULL;
|
|
u->flags.pad = PAD_YES;
|
|
u->flags.position = POSITION_ASIS;
|
|
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;
|
|
|
|
u->filename = strdup (stdin_name);
|
|
|
|
fbuf_init (u, 0);
|
|
|
|
UNLOCK (&u->lock);
|
|
}
|
|
|
|
if (options.stdout_unit >= 0)
|
|
{ /* STDOUT */
|
|
u = insert_unit (options.stdout_unit);
|
|
u->s = output_stream ();
|
|
|
|
u->flags.action = ACTION_WRITE;
|
|
|
|
u->flags.access = ACCESS_SEQUENTIAL;
|
|
u->flags.form = FORM_FORMATTED;
|
|
u->flags.status = STATUS_OLD;
|
|
u->flags.blank = BLANK_NULL;
|
|
u->flags.position = POSITION_ASIS;
|
|
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;
|
|
|
|
u->filename = strdup (stdout_name);
|
|
|
|
fbuf_init (u, 0);
|
|
|
|
UNLOCK (&u->lock);
|
|
}
|
|
|
|
if (options.stderr_unit >= 0)
|
|
{ /* STDERR */
|
|
u = insert_unit (options.stderr_unit);
|
|
u->s = error_stream ();
|
|
|
|
u->flags.action = ACTION_WRITE;
|
|
|
|
u->flags.access = ACCESS_SEQUENTIAL;
|
|
u->flags.form = FORM_FORMATTED;
|
|
u->flags.status = STATUS_OLD;
|
|
u->flags.blank = BLANK_NULL;
|
|
u->flags.position = POSITION_ASIS;
|
|
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;
|
|
|
|
u->filename = strdup (stderr_name);
|
|
|
|
fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
|
|
any kind of exotic formatting to stderr. */
|
|
|
|
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);
|
|
}
|
|
|
|
|
|
static int
|
|
close_unit_1 (gfc_unit *u, int locked)
|
|
{
|
|
int i, rc;
|
|
|
|
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)
|
|
LOCK (&unit_lock);
|
|
|
|
for (i = 0; i < CACHE_SIZE; i++)
|
|
if (unit_cache[i] == u)
|
|
unit_cache[i] = NULL;
|
|
|
|
delete_unit (u);
|
|
|
|
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)
|
|
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)
|
|
destroy_unit_mutex (u);
|
|
|
|
if (!locked)
|
|
UNLOCK (&unit_lock);
|
|
|
|
return rc;
|
|
}
|
|
|
|
void
|
|
unlock_unit (gfc_unit *u)
|
|
{
|
|
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. */
|
|
|
|
int
|
|
close_unit (gfc_unit *u)
|
|
{
|
|
return close_unit_1 (u, 0);
|
|
}
|
|
|
|
|
|
/* 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. */
|
|
|
|
void
|
|
close_units (void)
|
|
{
|
|
LOCK (&unit_lock);
|
|
while (unit_root != NULL)
|
|
close_unit_1 (unit_root, 1);
|
|
UNLOCK (&unit_lock);
|
|
|
|
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)
|
|
{
|
|
LOCK (&unit_lock);
|
|
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;
|
|
UNLOCK (&unit_lock);
|
|
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;
|
|
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;
|
|
}
|