1*0bfacb9bSmrg /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2760c2415Smrg Contributed by Andy Vaught
3760c2415Smrg F2003 I/O support contributed by Jerry DeLisle
4760c2415Smrg
5760c2415Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6760c2415Smrg
7760c2415Smrg Libgfortran is free software; you can redistribute it and/or modify
8760c2415Smrg it under the terms of the GNU General Public License as published by
9760c2415Smrg the Free Software Foundation; either version 3, or (at your option)
10760c2415Smrg any later version.
11760c2415Smrg
12760c2415Smrg Libgfortran is distributed in the hope that it will be useful,
13760c2415Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14760c2415Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15760c2415Smrg GNU General Public License for more details.
16760c2415Smrg
17760c2415Smrg Under Section 7 of GPL version 3, you are granted additional
18760c2415Smrg permissions described in the GCC Runtime Library Exception, version
19760c2415Smrg 3.1, as published by the Free Software Foundation.
20760c2415Smrg
21760c2415Smrg You should have received a copy of the GNU General Public License and
22760c2415Smrg a copy of the GCC Runtime Library Exception along with this program;
23760c2415Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24760c2415Smrg <http://www.gnu.org/licenses/>. */
25760c2415Smrg
26760c2415Smrg #include "io.h"
27760c2415Smrg #include "fbuf.h"
28760c2415Smrg #include "format.h"
29760c2415Smrg #include "unix.h"
30760c2415Smrg #include "async.h"
31760c2415Smrg #include <string.h>
32760c2415Smrg #include <assert.h>
33760c2415Smrg
34760c2415Smrg
35760c2415Smrg /* IO locking rules:
36760c2415Smrg UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
37760c2415Smrg Concurrent use of different units should be supported, so
38760c2415Smrg each unit has its own lock, LOCK.
39760c2415Smrg Open should be atomic with its reopening of units and list_read.c
40760c2415Smrg in several places needs find_unit another unit while holding stdin
41760c2415Smrg unit's lock, so it must be possible to acquire UNIT_LOCK while holding
42760c2415Smrg some unit's lock. Therefore to avoid deadlocks, it is forbidden
43760c2415Smrg to acquire unit's private locks while holding UNIT_LOCK, except
44760c2415Smrg for freshly created units (where no other thread can get at their
45760c2415Smrg address yet) or when using just trylock rather than lock operation.
46760c2415Smrg In addition to unit's private lock each unit has a WAITERS counter
47760c2415Smrg and CLOSED flag. WAITERS counter must be either only
48760c2415Smrg atomically incremented/decremented in all places (if atomic builtins
49760c2415Smrg are supported), or protected by UNIT_LOCK in all places (otherwise).
50760c2415Smrg CLOSED flag must be always protected by unit's LOCK.
51760c2415Smrg After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
52760c2415Smrg WAITERS must be incremented to avoid concurrent close from freeing
53760c2415Smrg the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
54760c2415Smrg Unit freeing is always done under UNIT_LOCK. If close_unit sees any
55760c2415Smrg WAITERS, it doesn't free the unit but instead sets the CLOSED flag
56760c2415Smrg and the thread that decrements WAITERS to zero while CLOSED flag is
57760c2415Smrg set is responsible for freeing it (while holding UNIT_LOCK).
58760c2415Smrg flush_all_units operation is iterating over the unit tree with
59760c2415Smrg increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
60760c2415Smrg flush each unit (and therefore needs the unit's LOCK held as well).
61760c2415Smrg To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
62760c2415Smrg remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
63760c2415Smrg unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
64760c2415Smrg the smallest UNIT_NUMBER above the last one flushed.
65760c2415Smrg
66760c2415Smrg If find_unit/find_or_create_unit/find_file/get_unit routines return
67760c2415Smrg non-NULL, the returned unit has its private lock locked and when the
68760c2415Smrg caller is done with it, it must call either unlock_unit or close_unit
69760c2415Smrg on it. unlock_unit or close_unit must be always called only with the
70760c2415Smrg private lock held. */
71760c2415Smrg
72760c2415Smrg
73760c2415Smrg
74760c2415Smrg /* Table of allocated newunit values. A simple solution would be to
75760c2415Smrg map OS file descriptors (fd's) to unit numbers, e.g. with newunit =
76760c2415Smrg -fd - 2, however that doesn't work since Fortran allows an existing
77760c2415Smrg unit number to be reassociated with a new file. Thus the simple
78760c2415Smrg approach may lead to a situation where we'd try to assign a
79760c2415Smrg (negative) unit number which already exists. Hence we must keep
80760c2415Smrg track of allocated newunit values ourselves. This is the purpose of
81760c2415Smrg the newunits array. The indices map to newunit values as newunit =
82760c2415Smrg -index + NEWUNIT_FIRST. E.g. newunits[0] having the value true
83760c2415Smrg means that a unit with number NEWUNIT_FIRST exists. Similar to
84760c2415Smrg POSIX file descriptors, we always allocate the lowest (in absolute
85760c2415Smrg value) available unit number.
86760c2415Smrg */
87760c2415Smrg static bool *newunits;
88760c2415Smrg static int newunit_size; /* Total number of elements in the newunits array. */
89760c2415Smrg /* Low water indicator for the newunits array. Below the LWI all the
90760c2415Smrg units are allocated, above and equal to the LWI there may be both
91760c2415Smrg allocated and free units. */
92760c2415Smrg static int newunit_lwi;
93760c2415Smrg
94760c2415Smrg /* Unit numbers assigned with NEWUNIT start from here. */
95760c2415Smrg #define NEWUNIT_START -10
96760c2415Smrg
97760c2415Smrg #define CACHE_SIZE 3
98760c2415Smrg static gfc_unit *unit_cache[CACHE_SIZE];
99760c2415Smrg
100760c2415Smrg gfc_offset max_offset;
101760c2415Smrg gfc_offset default_recl;
102760c2415Smrg
103760c2415Smrg gfc_unit *unit_root;
104760c2415Smrg #ifdef __GTHREAD_MUTEX_INIT
105760c2415Smrg __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
106760c2415Smrg #else
107760c2415Smrg __gthread_mutex_t unit_lock;
108760c2415Smrg #endif
109760c2415Smrg
110760c2415Smrg /* We use these filenames for error reporting. */
111760c2415Smrg
112760c2415Smrg static char stdin_name[] = "stdin";
113760c2415Smrg static char stdout_name[] = "stdout";
114760c2415Smrg static char stderr_name[] = "stderr";
115760c2415Smrg
116760c2415Smrg
117760c2415Smrg #ifdef HAVE_NEWLOCALE
118760c2415Smrg locale_t c_locale;
119760c2415Smrg #else
120760c2415Smrg /* If we don't have POSIX 2008 per-thread locales, we need to use the
121760c2415Smrg traditional setlocale(). To prevent multiple concurrent threads
122760c2415Smrg doing formatted I/O from messing up the locale, we need to store a
123760c2415Smrg global old_locale, and a counter keeping track of how many threads
124760c2415Smrg are currently doing formatted I/O. The first thread saves the old
125760c2415Smrg locale, and the last one restores it. */
126760c2415Smrg char *old_locale;
127760c2415Smrg int old_locale_ctr;
128760c2415Smrg #ifdef __GTHREAD_MUTEX_INIT
129760c2415Smrg __gthread_mutex_t old_locale_lock = __GTHREAD_MUTEX_INIT;
130760c2415Smrg #else
131760c2415Smrg __gthread_mutex_t old_locale_lock;
132760c2415Smrg #endif
133760c2415Smrg #endif
134760c2415Smrg
135760c2415Smrg
136760c2415Smrg /* This implementation is based on Stefan Nilsson's article in the
137760c2415Smrg July 1997 Doctor Dobb's Journal, "Treaps in Java". */
138760c2415Smrg
139760c2415Smrg /* pseudo_random()-- Simple linear congruential pseudorandom number
140760c2415Smrg generator. The period of this generator is 44071, which is plenty
141760c2415Smrg for our purposes. */
142760c2415Smrg
143760c2415Smrg static int
pseudo_random(void)144760c2415Smrg pseudo_random (void)
145760c2415Smrg {
146760c2415Smrg static int x0 = 5341;
147760c2415Smrg
148760c2415Smrg x0 = (22611 * x0 + 10) % 44071;
149760c2415Smrg return x0;
150760c2415Smrg }
151760c2415Smrg
152760c2415Smrg
153760c2415Smrg /* rotate_left()-- Rotate the treap left */
154760c2415Smrg
155760c2415Smrg static gfc_unit *
rotate_left(gfc_unit * t)156760c2415Smrg rotate_left (gfc_unit *t)
157760c2415Smrg {
158760c2415Smrg gfc_unit *temp;
159760c2415Smrg
160760c2415Smrg temp = t->right;
161760c2415Smrg t->right = t->right->left;
162760c2415Smrg temp->left = t;
163760c2415Smrg
164760c2415Smrg return temp;
165760c2415Smrg }
166760c2415Smrg
167760c2415Smrg
168760c2415Smrg /* rotate_right()-- Rotate the treap right */
169760c2415Smrg
170760c2415Smrg static gfc_unit *
rotate_right(gfc_unit * t)171760c2415Smrg rotate_right (gfc_unit *t)
172760c2415Smrg {
173760c2415Smrg gfc_unit *temp;
174760c2415Smrg
175760c2415Smrg temp = t->left;
176760c2415Smrg t->left = t->left->right;
177760c2415Smrg temp->right = t;
178760c2415Smrg
179760c2415Smrg return temp;
180760c2415Smrg }
181760c2415Smrg
182760c2415Smrg
183760c2415Smrg static int
compare(int a,int b)184760c2415Smrg compare (int a, int b)
185760c2415Smrg {
186760c2415Smrg if (a < b)
187760c2415Smrg return -1;
188760c2415Smrg if (a > b)
189760c2415Smrg return 1;
190760c2415Smrg
191760c2415Smrg return 0;
192760c2415Smrg }
193760c2415Smrg
194760c2415Smrg
195760c2415Smrg /* insert()-- Recursive insertion function. Returns the updated treap. */
196760c2415Smrg
197760c2415Smrg static gfc_unit *
insert(gfc_unit * new,gfc_unit * t)198760c2415Smrg insert (gfc_unit *new, gfc_unit *t)
199760c2415Smrg {
200760c2415Smrg int c;
201760c2415Smrg
202760c2415Smrg if (t == NULL)
203760c2415Smrg return new;
204760c2415Smrg
205760c2415Smrg c = compare (new->unit_number, t->unit_number);
206760c2415Smrg
207760c2415Smrg if (c < 0)
208760c2415Smrg {
209760c2415Smrg t->left = insert (new, t->left);
210760c2415Smrg if (t->priority < t->left->priority)
211760c2415Smrg t = rotate_right (t);
212760c2415Smrg }
213760c2415Smrg
214760c2415Smrg if (c > 0)
215760c2415Smrg {
216760c2415Smrg t->right = insert (new, t->right);
217760c2415Smrg if (t->priority < t->right->priority)
218760c2415Smrg t = rotate_left (t);
219760c2415Smrg }
220760c2415Smrg
221760c2415Smrg if (c == 0)
222760c2415Smrg internal_error (NULL, "insert(): Duplicate key found!");
223760c2415Smrg
224760c2415Smrg return t;
225760c2415Smrg }
226760c2415Smrg
227760c2415Smrg
228760c2415Smrg /* insert_unit()-- Create a new node, insert it into the treap. */
229760c2415Smrg
230760c2415Smrg static gfc_unit *
insert_unit(int n)231760c2415Smrg insert_unit (int n)
232760c2415Smrg {
233760c2415Smrg gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
234760c2415Smrg u->unit_number = n;
235760c2415Smrg u->internal_unit_kind = 0;
236760c2415Smrg #ifdef __GTHREAD_MUTEX_INIT
237760c2415Smrg {
238760c2415Smrg __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
239760c2415Smrg u->lock = tmp;
240760c2415Smrg }
241760c2415Smrg #else
242760c2415Smrg __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
243760c2415Smrg #endif
244760c2415Smrg LOCK (&u->lock);
245760c2415Smrg u->priority = pseudo_random ();
246760c2415Smrg unit_root = insert (u, unit_root);
247760c2415Smrg return u;
248760c2415Smrg }
249760c2415Smrg
250760c2415Smrg
251760c2415Smrg /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
252760c2415Smrg
253760c2415Smrg static void
destroy_unit_mutex(gfc_unit * u)254760c2415Smrg destroy_unit_mutex (gfc_unit *u)
255760c2415Smrg {
256760c2415Smrg __gthread_mutex_destroy (&u->lock);
257760c2415Smrg free (u);
258760c2415Smrg }
259760c2415Smrg
260760c2415Smrg
261760c2415Smrg static gfc_unit *
delete_root(gfc_unit * t)262760c2415Smrg delete_root (gfc_unit *t)
263760c2415Smrg {
264760c2415Smrg gfc_unit *temp;
265760c2415Smrg
266760c2415Smrg if (t->left == NULL)
267760c2415Smrg return t->right;
268760c2415Smrg if (t->right == NULL)
269760c2415Smrg return t->left;
270760c2415Smrg
271760c2415Smrg if (t->left->priority > t->right->priority)
272760c2415Smrg {
273760c2415Smrg temp = rotate_right (t);
274760c2415Smrg temp->right = delete_root (t);
275760c2415Smrg }
276760c2415Smrg else
277760c2415Smrg {
278760c2415Smrg temp = rotate_left (t);
279760c2415Smrg temp->left = delete_root (t);
280760c2415Smrg }
281760c2415Smrg
282760c2415Smrg return temp;
283760c2415Smrg }
284760c2415Smrg
285760c2415Smrg
286760c2415Smrg /* delete_treap()-- Delete an element from a tree. The 'old' value
287760c2415Smrg does not necessarily have to point to the element to be deleted, it
288760c2415Smrg must just point to a treap structure with the key to be deleted.
289760c2415Smrg Returns the new root node of the tree. */
290760c2415Smrg
291760c2415Smrg static gfc_unit *
delete_treap(gfc_unit * old,gfc_unit * t)292760c2415Smrg delete_treap (gfc_unit *old, gfc_unit *t)
293760c2415Smrg {
294760c2415Smrg int c;
295760c2415Smrg
296760c2415Smrg if (t == NULL)
297760c2415Smrg return NULL;
298760c2415Smrg
299760c2415Smrg c = compare (old->unit_number, t->unit_number);
300760c2415Smrg
301760c2415Smrg if (c < 0)
302760c2415Smrg t->left = delete_treap (old, t->left);
303760c2415Smrg if (c > 0)
304760c2415Smrg t->right = delete_treap (old, t->right);
305760c2415Smrg if (c == 0)
306760c2415Smrg t = delete_root (t);
307760c2415Smrg
308760c2415Smrg return t;
309760c2415Smrg }
310760c2415Smrg
311760c2415Smrg
312760c2415Smrg /* delete_unit()-- Delete a unit from a tree */
313760c2415Smrg
314760c2415Smrg static void
delete_unit(gfc_unit * old)315760c2415Smrg delete_unit (gfc_unit *old)
316760c2415Smrg {
317760c2415Smrg unit_root = delete_treap (old, unit_root);
318760c2415Smrg }
319760c2415Smrg
320760c2415Smrg
321760c2415Smrg /* get_gfc_unit()-- Given an integer, return a pointer to the unit
322760c2415Smrg structure. Returns NULL if the unit does not exist,
323760c2415Smrg otherwise returns a locked unit. */
324760c2415Smrg
325760c2415Smrg static gfc_unit *
get_gfc_unit(int n,int do_create)326760c2415Smrg get_gfc_unit (int n, int do_create)
327760c2415Smrg {
328760c2415Smrg gfc_unit *p;
329760c2415Smrg int c, created = 0;
330760c2415Smrg
331760c2415Smrg NOTE ("Unit n=%d, do_create = %d", n, do_create);
332760c2415Smrg LOCK (&unit_lock);
333760c2415Smrg
334760c2415Smrg retry:
335760c2415Smrg for (c = 0; c < CACHE_SIZE; c++)
336760c2415Smrg if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
337760c2415Smrg {
338760c2415Smrg p = unit_cache[c];
339760c2415Smrg goto found;
340760c2415Smrg }
341760c2415Smrg
342760c2415Smrg p = unit_root;
343760c2415Smrg while (p != NULL)
344760c2415Smrg {
345760c2415Smrg c = compare (n, p->unit_number);
346760c2415Smrg if (c < 0)
347760c2415Smrg p = p->left;
348760c2415Smrg if (c > 0)
349760c2415Smrg p = p->right;
350760c2415Smrg if (c == 0)
351760c2415Smrg break;
352760c2415Smrg }
353760c2415Smrg
354760c2415Smrg if (p == NULL && do_create)
355760c2415Smrg {
356760c2415Smrg p = insert_unit (n);
357760c2415Smrg created = 1;
358760c2415Smrg }
359760c2415Smrg
360760c2415Smrg if (p != NULL)
361760c2415Smrg {
362760c2415Smrg for (c = 0; c < CACHE_SIZE - 1; c++)
363760c2415Smrg unit_cache[c] = unit_cache[c + 1];
364760c2415Smrg
365760c2415Smrg unit_cache[CACHE_SIZE - 1] = p;
366760c2415Smrg }
367760c2415Smrg
368760c2415Smrg if (created)
369760c2415Smrg {
370760c2415Smrg /* Newly created units have their lock held already
371760c2415Smrg from insert_unit. Just unlock UNIT_LOCK and return. */
372760c2415Smrg UNLOCK (&unit_lock);
373760c2415Smrg return p;
374760c2415Smrg }
375760c2415Smrg
376760c2415Smrg found:
377760c2415Smrg if (p != NULL && (p->child_dtio == 0))
378760c2415Smrg {
379760c2415Smrg /* Fast path. */
380760c2415Smrg if (! TRYLOCK (&p->lock))
381760c2415Smrg {
382760c2415Smrg /* assert (p->closed == 0); */
383760c2415Smrg UNLOCK (&unit_lock);
384760c2415Smrg return p;
385760c2415Smrg }
386760c2415Smrg
387760c2415Smrg inc_waiting_locked (p);
388760c2415Smrg }
389760c2415Smrg
390760c2415Smrg
391760c2415Smrg UNLOCK (&unit_lock);
392760c2415Smrg
393760c2415Smrg if (p != NULL && (p->child_dtio == 0))
394760c2415Smrg {
395760c2415Smrg LOCK (&p->lock);
396760c2415Smrg if (p->closed)
397760c2415Smrg {
398760c2415Smrg LOCK (&unit_lock);
399760c2415Smrg UNLOCK (&p->lock);
400760c2415Smrg if (predec_waiting_locked (p) == 0)
401760c2415Smrg destroy_unit_mutex (p);
402760c2415Smrg goto retry;
403760c2415Smrg }
404760c2415Smrg
405760c2415Smrg dec_waiting_unlocked (p);
406760c2415Smrg }
407760c2415Smrg return p;
408760c2415Smrg }
409760c2415Smrg
410760c2415Smrg
411760c2415Smrg gfc_unit *
find_unit(int n)412760c2415Smrg find_unit (int n)
413760c2415Smrg {
414760c2415Smrg return get_gfc_unit (n, 0);
415760c2415Smrg }
416760c2415Smrg
417760c2415Smrg
418760c2415Smrg gfc_unit *
find_or_create_unit(int n)419760c2415Smrg find_or_create_unit (int n)
420760c2415Smrg {
421760c2415Smrg return get_gfc_unit (n, 1);
422760c2415Smrg }
423760c2415Smrg
424760c2415Smrg
425760c2415Smrg /* Helper function to check rank, stride, format string, and namelist.
426760c2415Smrg This is used for optimization. You can't trim out blanks or shorten
427760c2415Smrg the string if trailing spaces are significant. */
428760c2415Smrg static bool
is_trim_ok(st_parameter_dt * dtp)429760c2415Smrg is_trim_ok (st_parameter_dt *dtp)
430760c2415Smrg {
431760c2415Smrg /* Check rank and stride. */
432760c2415Smrg if (dtp->internal_unit_desc)
433760c2415Smrg return false;
434760c2415Smrg /* Format strings cannot have 'BZ' or '/'. */
435760c2415Smrg if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
436760c2415Smrg {
437760c2415Smrg char *p = dtp->format;
438760c2415Smrg if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
439760c2415Smrg return false;
440760c2415Smrg for (gfc_charlen_type i = 0; i < dtp->format_len; i++)
441760c2415Smrg {
442760c2415Smrg if (p[i] == '/') return false;
443760c2415Smrg if (p[i] == 'b' || p[i] == 'B')
444760c2415Smrg if (p[i+1] == 'z' || p[i+1] == 'Z')
445760c2415Smrg return false;
446760c2415Smrg }
447760c2415Smrg }
448760c2415Smrg if (dtp->u.p.ionml) /* A namelist. */
449760c2415Smrg return false;
450760c2415Smrg return true;
451760c2415Smrg }
452760c2415Smrg
453760c2415Smrg
454760c2415Smrg gfc_unit *
set_internal_unit(st_parameter_dt * dtp,gfc_unit * iunit,int kind)455760c2415Smrg set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
456760c2415Smrg {
457760c2415Smrg gfc_offset start_record = 0;
458760c2415Smrg
459760c2415Smrg iunit->unit_number = dtp->common.unit;
460760c2415Smrg iunit->recl = dtp->internal_unit_len;
461760c2415Smrg iunit->internal_unit = dtp->internal_unit;
462760c2415Smrg iunit->internal_unit_len = dtp->internal_unit_len;
463760c2415Smrg iunit->internal_unit_kind = kind;
464760c2415Smrg
465760c2415Smrg /* As an optimization, adjust the unit record length to not
466760c2415Smrg include trailing blanks. This will not work under certain conditions
467760c2415Smrg where trailing blanks have significance. */
468760c2415Smrg if (dtp->u.p.mode == READING && is_trim_ok (dtp))
469760c2415Smrg {
470760c2415Smrg int len;
471760c2415Smrg if (kind == 1)
472760c2415Smrg len = string_len_trim (iunit->internal_unit_len,
473760c2415Smrg iunit->internal_unit);
474760c2415Smrg else
475760c2415Smrg len = string_len_trim_char4 (iunit->internal_unit_len,
476760c2415Smrg (const gfc_char4_t*) iunit->internal_unit);
477760c2415Smrg iunit->internal_unit_len = len;
478760c2415Smrg iunit->recl = iunit->internal_unit_len;
479760c2415Smrg }
480760c2415Smrg
481760c2415Smrg /* Set up the looping specification from the array descriptor, if any. */
482760c2415Smrg
483760c2415Smrg if (is_array_io (dtp))
484760c2415Smrg {
485760c2415Smrg iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
486760c2415Smrg iunit->ls = (array_loop_spec *)
487760c2415Smrg xmallocarray (iunit->rank, sizeof (array_loop_spec));
488760c2415Smrg iunit->internal_unit_len *=
489760c2415Smrg init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
490760c2415Smrg
491760c2415Smrg start_record *= iunit->recl;
492760c2415Smrg }
493760c2415Smrg
494760c2415Smrg /* Set initial values for unit parameters. */
495760c2415Smrg if (kind == 4)
496760c2415Smrg iunit->s = open_internal4 (iunit->internal_unit - start_record,
497760c2415Smrg iunit->internal_unit_len, -start_record);
498760c2415Smrg else
499760c2415Smrg iunit->s = open_internal (iunit->internal_unit - start_record,
500760c2415Smrg iunit->internal_unit_len, -start_record);
501760c2415Smrg
502760c2415Smrg iunit->bytes_left = iunit->recl;
503760c2415Smrg iunit->last_record=0;
504760c2415Smrg iunit->maxrec=0;
505760c2415Smrg iunit->current_record=0;
506760c2415Smrg iunit->read_bad = 0;
507760c2415Smrg iunit->endfile = NO_ENDFILE;
508760c2415Smrg
509760c2415Smrg /* Set flags for the internal unit. */
510760c2415Smrg
511760c2415Smrg iunit->flags.access = ACCESS_SEQUENTIAL;
512760c2415Smrg iunit->flags.action = ACTION_READWRITE;
513760c2415Smrg iunit->flags.blank = BLANK_NULL;
514760c2415Smrg iunit->flags.form = FORM_FORMATTED;
515760c2415Smrg iunit->flags.pad = PAD_YES;
516760c2415Smrg iunit->flags.status = STATUS_UNSPECIFIED;
517760c2415Smrg iunit->flags.sign = SIGN_PROCDEFINED;
518760c2415Smrg iunit->flags.decimal = DECIMAL_POINT;
519760c2415Smrg iunit->flags.delim = DELIM_UNSPECIFIED;
520760c2415Smrg iunit->flags.encoding = ENCODING_DEFAULT;
521760c2415Smrg iunit->flags.async = ASYNC_NO;
522760c2415Smrg iunit->flags.round = ROUND_PROCDEFINED;
523760c2415Smrg
524760c2415Smrg /* Initialize the data transfer parameters. */
525760c2415Smrg
526760c2415Smrg dtp->u.p.advance_status = ADVANCE_YES;
527760c2415Smrg dtp->u.p.seen_dollar = 0;
528760c2415Smrg dtp->u.p.skips = 0;
529760c2415Smrg dtp->u.p.pending_spaces = 0;
530760c2415Smrg dtp->u.p.max_pos = 0;
531760c2415Smrg dtp->u.p.at_eof = 0;
532760c2415Smrg return iunit;
533760c2415Smrg }
534760c2415Smrg
535760c2415Smrg
536760c2415Smrg /* get_unit()-- Returns the unit structure associated with the integer
537760c2415Smrg unit or the internal file. */
538760c2415Smrg
539760c2415Smrg gfc_unit *
get_unit(st_parameter_dt * dtp,int do_create)540760c2415Smrg get_unit (st_parameter_dt *dtp, int do_create)
541760c2415Smrg {
542760c2415Smrg gfc_unit *unit;
543760c2415Smrg
544760c2415Smrg if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
545760c2415Smrg {
546760c2415Smrg int kind;
547760c2415Smrg if (dtp->common.unit == GFC_INTERNAL_UNIT)
548760c2415Smrg kind = 1;
549760c2415Smrg else if (dtp->common.unit == GFC_INTERNAL_UNIT4)
550760c2415Smrg kind = 4;
551760c2415Smrg else
552760c2415Smrg internal_error (&dtp->common, "get_unit(): Bad internal unit KIND");
553760c2415Smrg
554760c2415Smrg dtp->u.p.unit_is_internal = 1;
555760c2415Smrg dtp->common.unit = newunit_alloc ();
556760c2415Smrg unit = get_gfc_unit (dtp->common.unit, do_create);
557760c2415Smrg set_internal_unit (dtp, unit, kind);
558760c2415Smrg fbuf_init (unit, 128);
559760c2415Smrg return unit;
560760c2415Smrg }
561760c2415Smrg
562760c2415Smrg /* Has to be an external unit. */
563760c2415Smrg dtp->u.p.unit_is_internal = 0;
564760c2415Smrg dtp->internal_unit = NULL;
565760c2415Smrg dtp->internal_unit_desc = NULL;
566760c2415Smrg
567760c2415Smrg /* For an external unit with unit number < 0 creating it on the fly
568760c2415Smrg is not allowed, such units must be created with
569760c2415Smrg OPEN(NEWUNIT=...). */
570760c2415Smrg if (dtp->common.unit < 0)
571760c2415Smrg {
572760c2415Smrg if (dtp->common.unit > NEWUNIT_START) /* Reserved units. */
573760c2415Smrg return NULL;
574760c2415Smrg return get_gfc_unit (dtp->common.unit, 0);
575760c2415Smrg }
576760c2415Smrg
577760c2415Smrg return get_gfc_unit (dtp->common.unit, do_create);
578760c2415Smrg }
579760c2415Smrg
580760c2415Smrg
581760c2415Smrg /*************************/
582760c2415Smrg /* Initialize everything. */
583760c2415Smrg
584760c2415Smrg void
init_units(void)585760c2415Smrg init_units (void)
586760c2415Smrg {
587760c2415Smrg gfc_unit *u;
588760c2415Smrg
589760c2415Smrg #ifdef HAVE_NEWLOCALE
590760c2415Smrg c_locale = newlocale (0, "C", 0);
591760c2415Smrg #else
592760c2415Smrg #ifndef __GTHREAD_MUTEX_INIT
593760c2415Smrg __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
594760c2415Smrg #endif
595760c2415Smrg #endif
596760c2415Smrg
597760c2415Smrg #ifndef __GTHREAD_MUTEX_INIT
598760c2415Smrg __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
599760c2415Smrg #endif
600760c2415Smrg
601760c2415Smrg if (sizeof (max_offset) == 8)
602760c2415Smrg {
603760c2415Smrg max_offset = GFC_INTEGER_8_HUGE;
604760c2415Smrg /* Why this weird value? Because if the recl specifier in the
605760c2415Smrg inquire statement is a 4 byte value, u->recl is truncated,
606760c2415Smrg and this trick ensures it becomes HUGE(0) rather than -1.
607760c2415Smrg The full 8 byte value of default_recl is still 0.99999999 *
608760c2415Smrg max_offset which is large enough for all practical
609760c2415Smrg purposes. */
610760c2415Smrg default_recl = max_offset & ~(1LL<<31);
611760c2415Smrg }
612760c2415Smrg else if (sizeof (max_offset) == 4)
613760c2415Smrg max_offset = default_recl = GFC_INTEGER_4_HUGE;
614760c2415Smrg else
615760c2415Smrg internal_error (NULL, "sizeof (max_offset) must be 4 or 8");
616760c2415Smrg
617760c2415Smrg if (options.stdin_unit >= 0)
618760c2415Smrg { /* STDIN */
619760c2415Smrg u = insert_unit (options.stdin_unit);
620760c2415Smrg u->s = input_stream ();
621760c2415Smrg
622760c2415Smrg u->flags.action = ACTION_READ;
623760c2415Smrg
624760c2415Smrg u->flags.access = ACCESS_SEQUENTIAL;
625760c2415Smrg u->flags.form = FORM_FORMATTED;
626760c2415Smrg u->flags.status = STATUS_OLD;
627760c2415Smrg u->flags.blank = BLANK_NULL;
628760c2415Smrg u->flags.pad = PAD_YES;
629760c2415Smrg u->flags.position = POSITION_ASIS;
630760c2415Smrg u->flags.sign = SIGN_PROCDEFINED;
631760c2415Smrg u->flags.decimal = DECIMAL_POINT;
632760c2415Smrg u->flags.delim = DELIM_UNSPECIFIED;
633760c2415Smrg u->flags.encoding = ENCODING_DEFAULT;
634760c2415Smrg u->flags.async = ASYNC_NO;
635760c2415Smrg u->flags.round = ROUND_PROCDEFINED;
636760c2415Smrg u->flags.share = SHARE_UNSPECIFIED;
637760c2415Smrg u->flags.cc = CC_LIST;
638760c2415Smrg
639760c2415Smrg u->recl = default_recl;
640760c2415Smrg u->endfile = NO_ENDFILE;
641760c2415Smrg
642760c2415Smrg u->filename = strdup (stdin_name);
643760c2415Smrg
644760c2415Smrg fbuf_init (u, 0);
645760c2415Smrg
646760c2415Smrg UNLOCK (&u->lock);
647760c2415Smrg }
648760c2415Smrg
649760c2415Smrg if (options.stdout_unit >= 0)
650760c2415Smrg { /* STDOUT */
651760c2415Smrg u = insert_unit (options.stdout_unit);
652760c2415Smrg u->s = output_stream ();
653760c2415Smrg
654760c2415Smrg u->flags.action = ACTION_WRITE;
655760c2415Smrg
656760c2415Smrg u->flags.access = ACCESS_SEQUENTIAL;
657760c2415Smrg u->flags.form = FORM_FORMATTED;
658760c2415Smrg u->flags.status = STATUS_OLD;
659760c2415Smrg u->flags.blank = BLANK_NULL;
660760c2415Smrg u->flags.position = POSITION_ASIS;
661760c2415Smrg u->flags.sign = SIGN_PROCDEFINED;
662760c2415Smrg u->flags.decimal = DECIMAL_POINT;
663760c2415Smrg u->flags.delim = DELIM_UNSPECIFIED;
664760c2415Smrg u->flags.encoding = ENCODING_DEFAULT;
665760c2415Smrg u->flags.async = ASYNC_NO;
666760c2415Smrg u->flags.round = ROUND_PROCDEFINED;
667760c2415Smrg u->flags.share = SHARE_UNSPECIFIED;
668760c2415Smrg u->flags.cc = CC_LIST;
669760c2415Smrg
670760c2415Smrg u->recl = default_recl;
671760c2415Smrg u->endfile = AT_ENDFILE;
672760c2415Smrg
673760c2415Smrg u->filename = strdup (stdout_name);
674760c2415Smrg
675760c2415Smrg fbuf_init (u, 0);
676760c2415Smrg
677760c2415Smrg UNLOCK (&u->lock);
678760c2415Smrg }
679760c2415Smrg
680760c2415Smrg if (options.stderr_unit >= 0)
681760c2415Smrg { /* STDERR */
682760c2415Smrg u = insert_unit (options.stderr_unit);
683760c2415Smrg u->s = error_stream ();
684760c2415Smrg
685760c2415Smrg u->flags.action = ACTION_WRITE;
686760c2415Smrg
687760c2415Smrg u->flags.access = ACCESS_SEQUENTIAL;
688760c2415Smrg u->flags.form = FORM_FORMATTED;
689760c2415Smrg u->flags.status = STATUS_OLD;
690760c2415Smrg u->flags.blank = BLANK_NULL;
691760c2415Smrg u->flags.position = POSITION_ASIS;
692760c2415Smrg u->flags.sign = SIGN_PROCDEFINED;
693760c2415Smrg u->flags.decimal = DECIMAL_POINT;
694760c2415Smrg u->flags.encoding = ENCODING_DEFAULT;
695760c2415Smrg u->flags.async = ASYNC_NO;
696760c2415Smrg u->flags.round = ROUND_PROCDEFINED;
697760c2415Smrg u->flags.share = SHARE_UNSPECIFIED;
698760c2415Smrg u->flags.cc = CC_LIST;
699760c2415Smrg
700760c2415Smrg u->recl = default_recl;
701760c2415Smrg u->endfile = AT_ENDFILE;
702760c2415Smrg
703760c2415Smrg u->filename = strdup (stderr_name);
704760c2415Smrg
705760c2415Smrg fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
706760c2415Smrg any kind of exotic formatting to stderr. */
707760c2415Smrg
708760c2415Smrg UNLOCK (&u->lock);
709760c2415Smrg }
710760c2415Smrg /* The default internal units. */
711760c2415Smrg u = insert_unit (GFC_INTERNAL_UNIT);
712760c2415Smrg UNLOCK (&u->lock);
713760c2415Smrg u = insert_unit (GFC_INTERNAL_UNIT4);
714760c2415Smrg UNLOCK (&u->lock);
715760c2415Smrg }
716760c2415Smrg
717760c2415Smrg
718760c2415Smrg static int
close_unit_1(gfc_unit * u,int locked)719760c2415Smrg close_unit_1 (gfc_unit *u, int locked)
720760c2415Smrg {
721760c2415Smrg int i, rc;
722760c2415Smrg
723760c2415Smrg if (ASYNC_IO && u->au)
724760c2415Smrg async_close (u->au);
725760c2415Smrg
726760c2415Smrg /* If there are previously written bytes from a write with ADVANCE="no"
727760c2415Smrg Reposition the buffer before closing. */
728760c2415Smrg if (u->previous_nonadvancing_write)
729760c2415Smrg finish_last_advance_record (u);
730760c2415Smrg
731760c2415Smrg rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
732760c2415Smrg
733760c2415Smrg u->closed = 1;
734760c2415Smrg if (!locked)
735760c2415Smrg LOCK (&unit_lock);
736760c2415Smrg
737760c2415Smrg for (i = 0; i < CACHE_SIZE; i++)
738760c2415Smrg if (unit_cache[i] == u)
739760c2415Smrg unit_cache[i] = NULL;
740760c2415Smrg
741760c2415Smrg delete_unit (u);
742760c2415Smrg
743760c2415Smrg free (u->filename);
744760c2415Smrg u->filename = NULL;
745760c2415Smrg
746760c2415Smrg free_format_hash_table (u);
747760c2415Smrg fbuf_destroy (u);
748760c2415Smrg
749760c2415Smrg if (u->unit_number <= NEWUNIT_START)
750760c2415Smrg newunit_free (u->unit_number);
751760c2415Smrg
752760c2415Smrg if (!locked)
753760c2415Smrg UNLOCK (&u->lock);
754760c2415Smrg
755760c2415Smrg /* If there are any threads waiting in find_unit for this unit,
756760c2415Smrg avoid freeing the memory, the last such thread will free it
757760c2415Smrg instead. */
758760c2415Smrg if (u->waiting == 0)
759760c2415Smrg destroy_unit_mutex (u);
760760c2415Smrg
761760c2415Smrg if (!locked)
762760c2415Smrg UNLOCK (&unit_lock);
763760c2415Smrg
764760c2415Smrg return rc;
765760c2415Smrg }
766760c2415Smrg
767760c2415Smrg void
unlock_unit(gfc_unit * u)768760c2415Smrg unlock_unit (gfc_unit *u)
769760c2415Smrg {
770*0bfacb9bSmrg if (u)
771*0bfacb9bSmrg {
772760c2415Smrg NOTE ("unlock_unit = %d", u->unit_number);
773760c2415Smrg UNLOCK (&u->lock);
774760c2415Smrg NOTE ("unlock_unit done");
775760c2415Smrg }
776*0bfacb9bSmrg }
777760c2415Smrg
778760c2415Smrg /* close_unit()-- Close a unit. The stream is closed, and any memory
779760c2415Smrg associated with the stream is freed. Returns nonzero on I/O error.
780760c2415Smrg Should be called with the u->lock locked. */
781760c2415Smrg
782760c2415Smrg int
close_unit(gfc_unit * u)783760c2415Smrg close_unit (gfc_unit *u)
784760c2415Smrg {
785760c2415Smrg return close_unit_1 (u, 0);
786760c2415Smrg }
787760c2415Smrg
788760c2415Smrg
789760c2415Smrg /* close_units()-- Delete units on completion. We just keep deleting
790760c2415Smrg the root of the treap until there is nothing left.
791760c2415Smrg Not sure what to do with locking here. Some other thread might be
792760c2415Smrg holding some unit's lock and perhaps hold it indefinitely
793760c2415Smrg (e.g. waiting for input from some pipe) and close_units shouldn't
794760c2415Smrg delay the program too much. */
795760c2415Smrg
796760c2415Smrg void
close_units(void)797760c2415Smrg close_units (void)
798760c2415Smrg {
799760c2415Smrg LOCK (&unit_lock);
800760c2415Smrg while (unit_root != NULL)
801760c2415Smrg close_unit_1 (unit_root, 1);
802760c2415Smrg UNLOCK (&unit_lock);
803760c2415Smrg
804760c2415Smrg free (newunits);
805760c2415Smrg
806760c2415Smrg #ifdef HAVE_FREELOCALE
807760c2415Smrg freelocale (c_locale);
808760c2415Smrg #endif
809760c2415Smrg }
810760c2415Smrg
811760c2415Smrg
812760c2415Smrg /* High level interface to truncate a file, i.e. flush format buffers,
813760c2415Smrg and generate an error or set some flags. Just like POSIX
814760c2415Smrg ftruncate, returns 0 on success, -1 on failure. */
815760c2415Smrg
816760c2415Smrg int
unit_truncate(gfc_unit * u,gfc_offset pos,st_parameter_common * common)817760c2415Smrg unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
818760c2415Smrg {
819760c2415Smrg int ret;
820760c2415Smrg
821760c2415Smrg /* Make sure format buffer is flushed. */
822760c2415Smrg if (u->flags.form == FORM_FORMATTED)
823760c2415Smrg {
824760c2415Smrg if (u->mode == READING)
825760c2415Smrg pos += fbuf_reset (u);
826760c2415Smrg else
827760c2415Smrg fbuf_flush (u, u->mode);
828760c2415Smrg }
829760c2415Smrg
830760c2415Smrg /* struncate() should flush the stream buffer if necessary, so don't
831760c2415Smrg bother calling sflush() here. */
832760c2415Smrg ret = struncate (u->s, pos);
833760c2415Smrg
834760c2415Smrg if (ret != 0)
835760c2415Smrg generate_error (common, LIBERROR_OS, NULL);
836760c2415Smrg else
837760c2415Smrg {
838760c2415Smrg u->endfile = AT_ENDFILE;
839760c2415Smrg u->flags.position = POSITION_APPEND;
840760c2415Smrg }
841760c2415Smrg
842760c2415Smrg return ret;
843760c2415Smrg }
844760c2415Smrg
845760c2415Smrg
846760c2415Smrg /* filename_from_unit()-- If the unit_number exists, return a pointer to the
847760c2415Smrg name of the associated file, otherwise return the empty string. The caller
848760c2415Smrg must free memory allocated for the filename string. */
849760c2415Smrg
850760c2415Smrg char *
filename_from_unit(int n)851760c2415Smrg filename_from_unit (int n)
852760c2415Smrg {
853760c2415Smrg gfc_unit *u;
854760c2415Smrg int c;
855760c2415Smrg
856760c2415Smrg /* Find the unit. */
857760c2415Smrg u = unit_root;
858760c2415Smrg while (u != NULL)
859760c2415Smrg {
860760c2415Smrg c = compare (n, u->unit_number);
861760c2415Smrg if (c < 0)
862760c2415Smrg u = u->left;
863760c2415Smrg if (c > 0)
864760c2415Smrg u = u->right;
865760c2415Smrg if (c == 0)
866760c2415Smrg break;
867760c2415Smrg }
868760c2415Smrg
869760c2415Smrg /* Get the filename. */
870760c2415Smrg if (u != NULL && u->filename != NULL)
871760c2415Smrg return strdup (u->filename);
872760c2415Smrg else
873760c2415Smrg return (char *) NULL;
874760c2415Smrg }
875760c2415Smrg
876760c2415Smrg void
finish_last_advance_record(gfc_unit * u)877760c2415Smrg finish_last_advance_record (gfc_unit *u)
878760c2415Smrg {
879760c2415Smrg
880760c2415Smrg if (u->saved_pos > 0)
881760c2415Smrg fbuf_seek (u, u->saved_pos, SEEK_CUR);
882760c2415Smrg
883760c2415Smrg if (!(u->unit_number == options.stdout_unit
884760c2415Smrg || u->unit_number == options.stderr_unit))
885760c2415Smrg {
886760c2415Smrg #ifdef HAVE_CRLF
887760c2415Smrg const int len = 2;
888760c2415Smrg #else
889760c2415Smrg const int len = 1;
890760c2415Smrg #endif
891760c2415Smrg char *p = fbuf_alloc (u, len);
892760c2415Smrg if (!p)
893760c2415Smrg os_error ("Completing record after ADVANCE_NO failed");
894760c2415Smrg #ifdef HAVE_CRLF
895760c2415Smrg *(p++) = '\r';
896760c2415Smrg #endif
897760c2415Smrg *p = '\n';
898760c2415Smrg }
899760c2415Smrg
900760c2415Smrg fbuf_flush (u, u->mode);
901760c2415Smrg }
902760c2415Smrg
903760c2415Smrg
904760c2415Smrg /* Assign a negative number for NEWUNIT in OPEN statements or for
905760c2415Smrg internal units. */
906760c2415Smrg int
newunit_alloc(void)907760c2415Smrg newunit_alloc (void)
908760c2415Smrg {
909760c2415Smrg LOCK (&unit_lock);
910760c2415Smrg if (!newunits)
911760c2415Smrg {
912760c2415Smrg newunits = xcalloc (16, 1);
913760c2415Smrg newunit_size = 16;
914760c2415Smrg }
915760c2415Smrg
916760c2415Smrg /* Search for the next available newunit. */
917760c2415Smrg for (int ii = newunit_lwi; ii < newunit_size; ii++)
918760c2415Smrg {
919760c2415Smrg if (!newunits[ii])
920760c2415Smrg {
921760c2415Smrg newunits[ii] = true;
922760c2415Smrg newunit_lwi = ii + 1;
923760c2415Smrg UNLOCK (&unit_lock);
924760c2415Smrg return -ii + NEWUNIT_START;
925760c2415Smrg }
926760c2415Smrg }
927760c2415Smrg
928760c2415Smrg /* Search failed, bump size of array and allocate the first
929760c2415Smrg available unit. */
930760c2415Smrg int old_size = newunit_size;
931760c2415Smrg newunit_size *= 2;
932760c2415Smrg newunits = xrealloc (newunits, newunit_size);
933760c2415Smrg memset (newunits + old_size, 0, old_size);
934760c2415Smrg newunits[old_size] = true;
935760c2415Smrg newunit_lwi = old_size + 1;
936760c2415Smrg UNLOCK (&unit_lock);
937760c2415Smrg return -old_size + NEWUNIT_START;
938760c2415Smrg }
939760c2415Smrg
940760c2415Smrg
941760c2415Smrg /* Free a previously allocated newunit= unit number. unit_lock must
942760c2415Smrg be held when calling. */
943760c2415Smrg
944760c2415Smrg void
newunit_free(int unit)945760c2415Smrg newunit_free (int unit)
946760c2415Smrg {
947760c2415Smrg int ind = -unit + NEWUNIT_START;
948760c2415Smrg assert(ind >= 0 && ind < newunit_size);
949760c2415Smrg newunits[ind] = false;
950760c2415Smrg if (ind < newunit_lwi)
951760c2415Smrg newunit_lwi = ind;
952760c2415Smrg }
953