1 /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
10 any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 #include "io.h"
27 #include "fbuf.h"
28 #include "format.h"
29 #include "unix.h"
30 #include "async.h"
31 #include <string.h>
32 #include <assert.h>
33
34
35 /* IO locking rules:
36 UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
37 Concurrent use of different units should be supported, so
38 each unit has its own lock, LOCK.
39 Open should be atomic with its reopening of units and list_read.c
40 in several places needs find_unit another unit while holding stdin
41 unit's lock, so it must be possible to acquire UNIT_LOCK while holding
42 some unit's lock. Therefore to avoid deadlocks, it is forbidden
43 to acquire unit's private locks while holding UNIT_LOCK, except
44 for freshly created units (where no other thread can get at their
45 address yet) or when using just trylock rather than lock operation.
46 In addition to unit's private lock each unit has a WAITERS counter
47 and CLOSED flag. WAITERS counter must be either only
48 atomically incremented/decremented in all places (if atomic builtins
49 are supported), or protected by UNIT_LOCK in all places (otherwise).
50 CLOSED flag must be always protected by unit's LOCK.
51 After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
52 WAITERS must be incremented to avoid concurrent close from freeing
53 the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
54 Unit freeing is always done under UNIT_LOCK. If close_unit sees any
55 WAITERS, it doesn't free the unit but instead sets the CLOSED flag
56 and the thread that decrements WAITERS to zero while CLOSED flag is
57 set is responsible for freeing it (while holding UNIT_LOCK).
58 flush_all_units operation is iterating over the unit tree with
59 increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
60 flush each unit (and therefore needs the unit's LOCK held as well).
61 To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
62 remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
63 unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
64 the smallest UNIT_NUMBER above the last one flushed.
65
66 If find_unit/find_or_create_unit/find_file/get_unit routines return
67 non-NULL, the returned unit has its private lock locked and when the
68 caller is done with it, it must call either unlock_unit or close_unit
69 on it. unlock_unit or close_unit must be always called only with the
70 private lock held. */
71
72
73
74 /* Table of allocated newunit values. A simple solution would be to
75 map OS file descriptors (fd's) to unit numbers, e.g. with newunit =
76 -fd - 2, however that doesn't work since Fortran allows an existing
77 unit number to be reassociated with a new file. Thus the simple
78 approach may lead to a situation where we'd try to assign a
79 (negative) unit number which already exists. Hence we must keep
80 track of allocated newunit values ourselves. This is the purpose of
81 the newunits array. The indices map to newunit values as newunit =
82 -index + NEWUNIT_FIRST. E.g. newunits[0] having the value true
83 means that a unit with number NEWUNIT_FIRST exists. Similar to
84 POSIX file descriptors, we always allocate the lowest (in absolute
85 value) available unit number.
86 */
87 static bool *newunits;
88 static int newunit_size; /* Total number of elements in the newunits array. */
89 /* Low water indicator for the newunits array. Below the LWI all the
90 units are allocated, above and equal to the LWI there may be both
91 allocated and free units. */
92 static int newunit_lwi;
93
94 /* Unit numbers assigned with NEWUNIT start from here. */
95 #define NEWUNIT_START -10
96
97 #define CACHE_SIZE 3
98 static gfc_unit *unit_cache[CACHE_SIZE];
99
100 gfc_offset max_offset;
101 gfc_offset default_recl;
102
103 gfc_unit *unit_root;
104 #ifdef __GTHREAD_MUTEX_INIT
105 __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
106 #else
107 __gthread_mutex_t unit_lock;
108 #endif
109
110 /* We use these filenames for error reporting. */
111
112 static char stdin_name[] = "stdin";
113 static char stdout_name[] = "stdout";
114 static char stderr_name[] = "stderr";
115
116
117 #ifdef HAVE_NEWLOCALE
118 locale_t c_locale;
119 #else
120 /* If we don't have POSIX 2008 per-thread locales, we need to use the
121 traditional setlocale(). To prevent multiple concurrent threads
122 doing formatted I/O from messing up the locale, we need to store a
123 global old_locale, and a counter keeping track of how many threads
124 are currently doing formatted I/O. The first thread saves the old
125 locale, and the last one restores it. */
126 char *old_locale;
127 int old_locale_ctr;
128 #ifdef __GTHREAD_MUTEX_INIT
129 __gthread_mutex_t old_locale_lock = __GTHREAD_MUTEX_INIT;
130 #else
131 __gthread_mutex_t old_locale_lock;
132 #endif
133 #endif
134
135
136 /* This implementation is based on Stefan Nilsson's article in the
137 July 1997 Doctor Dobb's Journal, "Treaps in Java". */
138
139 /* pseudo_random()-- Simple linear congruential pseudorandom number
140 generator. The period of this generator is 44071, which is plenty
141 for our purposes. */
142
143 static int
pseudo_random(void)144 pseudo_random (void)
145 {
146 static int x0 = 5341;
147
148 x0 = (22611 * x0 + 10) % 44071;
149 return x0;
150 }
151
152
153 /* rotate_left()-- Rotate the treap left */
154
155 static gfc_unit *
rotate_left(gfc_unit * t)156 rotate_left (gfc_unit *t)
157 {
158 gfc_unit *temp;
159
160 temp = t->right;
161 t->right = t->right->left;
162 temp->left = t;
163
164 return temp;
165 }
166
167
168 /* rotate_right()-- Rotate the treap right */
169
170 static gfc_unit *
rotate_right(gfc_unit * t)171 rotate_right (gfc_unit *t)
172 {
173 gfc_unit *temp;
174
175 temp = t->left;
176 t->left = t->left->right;
177 temp->right = t;
178
179 return temp;
180 }
181
182
183 static int
compare(int a,int b)184 compare (int a, int b)
185 {
186 if (a < b)
187 return -1;
188 if (a > b)
189 return 1;
190
191 return 0;
192 }
193
194
195 /* insert()-- Recursive insertion function. Returns the updated treap. */
196
197 static gfc_unit *
insert(gfc_unit * new,gfc_unit * t)198 insert (gfc_unit *new, gfc_unit *t)
199 {
200 int c;
201
202 if (t == NULL)
203 return new;
204
205 c = compare (new->unit_number, t->unit_number);
206
207 if (c < 0)
208 {
209 t->left = insert (new, t->left);
210 if (t->priority < t->left->priority)
211 t = rotate_right (t);
212 }
213
214 if (c > 0)
215 {
216 t->right = insert (new, t->right);
217 if (t->priority < t->right->priority)
218 t = rotate_left (t);
219 }
220
221 if (c == 0)
222 internal_error (NULL, "insert(): Duplicate key found!");
223
224 return t;
225 }
226
227
228 /* insert_unit()-- Create a new node, insert it into the treap. */
229
230 static gfc_unit *
insert_unit(int n)231 insert_unit (int n)
232 {
233 gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
234 u->unit_number = n;
235 u->internal_unit_kind = 0;
236 #ifdef __GTHREAD_MUTEX_INIT
237 {
238 __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
239 u->lock = tmp;
240 }
241 #else
242 __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
243 #endif
244 LOCK (&u->lock);
245 u->priority = pseudo_random ();
246 unit_root = insert (u, unit_root);
247 return u;
248 }
249
250
251 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
252
253 static void
destroy_unit_mutex(gfc_unit * u)254 destroy_unit_mutex (gfc_unit *u)
255 {
256 __gthread_mutex_destroy (&u->lock);
257 free (u);
258 }
259
260
261 static gfc_unit *
delete_root(gfc_unit * t)262 delete_root (gfc_unit *t)
263 {
264 gfc_unit *temp;
265
266 if (t->left == NULL)
267 return t->right;
268 if (t->right == NULL)
269 return t->left;
270
271 if (t->left->priority > t->right->priority)
272 {
273 temp = rotate_right (t);
274 temp->right = delete_root (t);
275 }
276 else
277 {
278 temp = rotate_left (t);
279 temp->left = delete_root (t);
280 }
281
282 return temp;
283 }
284
285
286 /* delete_treap()-- Delete an element from a tree. The 'old' value
287 does not necessarily have to point to the element to be deleted, it
288 must just point to a treap structure with the key to be deleted.
289 Returns the new root node of the tree. */
290
291 static gfc_unit *
delete_treap(gfc_unit * old,gfc_unit * t)292 delete_treap (gfc_unit *old, gfc_unit *t)
293 {
294 int c;
295
296 if (t == NULL)
297 return NULL;
298
299 c = compare (old->unit_number, t->unit_number);
300
301 if (c < 0)
302 t->left = delete_treap (old, t->left);
303 if (c > 0)
304 t->right = delete_treap (old, t->right);
305 if (c == 0)
306 t = delete_root (t);
307
308 return t;
309 }
310
311
312 /* delete_unit()-- Delete a unit from a tree */
313
314 static void
delete_unit(gfc_unit * old)315 delete_unit (gfc_unit *old)
316 {
317 unit_root = delete_treap (old, unit_root);
318 }
319
320
321 /* get_gfc_unit()-- Given an integer, return a pointer to the unit
322 structure. Returns NULL if the unit does not exist,
323 otherwise returns a locked unit. */
324
325 static gfc_unit *
get_gfc_unit(int n,int do_create)326 get_gfc_unit (int n, int do_create)
327 {
328 gfc_unit *p;
329 int c, created = 0;
330
331 NOTE ("Unit n=%d, do_create = %d", n, do_create);
332 LOCK (&unit_lock);
333
334 retry:
335 for (c = 0; c < CACHE_SIZE; c++)
336 if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
337 {
338 p = unit_cache[c];
339 goto found;
340 }
341
342 p = unit_root;
343 while (p != NULL)
344 {
345 c = compare (n, p->unit_number);
346 if (c < 0)
347 p = p->left;
348 if (c > 0)
349 p = p->right;
350 if (c == 0)
351 break;
352 }
353
354 if (p == NULL && do_create)
355 {
356 p = insert_unit (n);
357 created = 1;
358 }
359
360 if (p != NULL)
361 {
362 for (c = 0; c < CACHE_SIZE - 1; c++)
363 unit_cache[c] = unit_cache[c + 1];
364
365 unit_cache[CACHE_SIZE - 1] = p;
366 }
367
368 if (created)
369 {
370 /* Newly created units have their lock held already
371 from insert_unit. Just unlock UNIT_LOCK and return. */
372 UNLOCK (&unit_lock);
373 return p;
374 }
375
376 found:
377 if (p != NULL && (p->child_dtio == 0))
378 {
379 /* Fast path. */
380 if (! TRYLOCK (&p->lock))
381 {
382 /* assert (p->closed == 0); */
383 UNLOCK (&unit_lock);
384 return p;
385 }
386
387 inc_waiting_locked (p);
388 }
389
390
391 UNLOCK (&unit_lock);
392
393 if (p != NULL && (p->child_dtio == 0))
394 {
395 LOCK (&p->lock);
396 if (p->closed)
397 {
398 LOCK (&unit_lock);
399 UNLOCK (&p->lock);
400 if (predec_waiting_locked (p) == 0)
401 destroy_unit_mutex (p);
402 goto retry;
403 }
404
405 dec_waiting_unlocked (p);
406 }
407 return p;
408 }
409
410
411 gfc_unit *
find_unit(int n)412 find_unit (int n)
413 {
414 return get_gfc_unit (n, 0);
415 }
416
417
418 gfc_unit *
find_or_create_unit(int n)419 find_or_create_unit (int n)
420 {
421 return get_gfc_unit (n, 1);
422 }
423
424
425 /* Helper function to check rank, stride, format string, and namelist.
426 This is used for optimization. You can't trim out blanks or shorten
427 the string if trailing spaces are significant. */
428 static bool
is_trim_ok(st_parameter_dt * dtp)429 is_trim_ok (st_parameter_dt *dtp)
430 {
431 /* Check rank and stride. */
432 if (dtp->internal_unit_desc)
433 return false;
434 /* Format strings cannot have 'BZ' or '/'. */
435 if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
436 {
437 char *p = dtp->format;
438 if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
439 return false;
440 for (gfc_charlen_type i = 0; i < dtp->format_len; i++)
441 {
442 if (p[i] == '/') return false;
443 if (p[i] == 'b' || p[i] == 'B')
444 if (p[i+1] == 'z' || p[i+1] == 'Z')
445 return false;
446 }
447 }
448 if (dtp->u.p.ionml) /* A namelist. */
449 return false;
450 return true;
451 }
452
453
454 gfc_unit *
set_internal_unit(st_parameter_dt * dtp,gfc_unit * iunit,int kind)455 set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
456 {
457 gfc_offset start_record = 0;
458
459 iunit->unit_number = dtp->common.unit;
460 iunit->recl = dtp->internal_unit_len;
461 iunit->internal_unit = dtp->internal_unit;
462 iunit->internal_unit_len = dtp->internal_unit_len;
463 iunit->internal_unit_kind = kind;
464
465 /* As an optimization, adjust the unit record length to not
466 include trailing blanks. This will not work under certain conditions
467 where trailing blanks have significance. */
468 if (dtp->u.p.mode == READING && is_trim_ok (dtp))
469 {
470 int len;
471 if (kind == 1)
472 len = string_len_trim (iunit->internal_unit_len,
473 iunit->internal_unit);
474 else
475 len = string_len_trim_char4 (iunit->internal_unit_len,
476 (const gfc_char4_t*) iunit->internal_unit);
477 iunit->internal_unit_len = len;
478 iunit->recl = iunit->internal_unit_len;
479 }
480
481 /* Set up the looping specification from the array descriptor, if any. */
482
483 if (is_array_io (dtp))
484 {
485 iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
486 iunit->ls = (array_loop_spec *)
487 xmallocarray (iunit->rank, sizeof (array_loop_spec));
488 iunit->internal_unit_len *=
489 init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
490
491 start_record *= iunit->recl;
492 }
493
494 /* Set initial values for unit parameters. */
495 if (kind == 4)
496 iunit->s = open_internal4 (iunit->internal_unit - start_record,
497 iunit->internal_unit_len, -start_record);
498 else
499 iunit->s = open_internal (iunit->internal_unit - start_record,
500 iunit->internal_unit_len, -start_record);
501
502 iunit->bytes_left = iunit->recl;
503 iunit->last_record=0;
504 iunit->maxrec=0;
505 iunit->current_record=0;
506 iunit->read_bad = 0;
507 iunit->endfile = NO_ENDFILE;
508
509 /* Set flags for the internal unit. */
510
511 iunit->flags.access = ACCESS_SEQUENTIAL;
512 iunit->flags.action = ACTION_READWRITE;
513 iunit->flags.blank = BLANK_NULL;
514 iunit->flags.form = FORM_FORMATTED;
515 iunit->flags.pad = PAD_YES;
516 iunit->flags.status = STATUS_UNSPECIFIED;
517 iunit->flags.sign = SIGN_PROCDEFINED;
518 iunit->flags.decimal = DECIMAL_POINT;
519 iunit->flags.delim = DELIM_UNSPECIFIED;
520 iunit->flags.encoding = ENCODING_DEFAULT;
521 iunit->flags.async = ASYNC_NO;
522 iunit->flags.round = ROUND_PROCDEFINED;
523
524 /* Initialize the data transfer parameters. */
525
526 dtp->u.p.advance_status = ADVANCE_YES;
527 dtp->u.p.seen_dollar = 0;
528 dtp->u.p.skips = 0;
529 dtp->u.p.pending_spaces = 0;
530 dtp->u.p.max_pos = 0;
531 dtp->u.p.at_eof = 0;
532 return iunit;
533 }
534
535
536 /* get_unit()-- Returns the unit structure associated with the integer
537 unit or the internal file. */
538
539 gfc_unit *
get_unit(st_parameter_dt * dtp,int do_create)540 get_unit (st_parameter_dt *dtp, int do_create)
541 {
542 gfc_unit *unit;
543
544 if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
545 {
546 int kind;
547 if (dtp->common.unit == GFC_INTERNAL_UNIT)
548 kind = 1;
549 else if (dtp->common.unit == GFC_INTERNAL_UNIT4)
550 kind = 4;
551 else
552 internal_error (&dtp->common, "get_unit(): Bad internal unit KIND");
553
554 dtp->u.p.unit_is_internal = 1;
555 dtp->common.unit = newunit_alloc ();
556 unit = get_gfc_unit (dtp->common.unit, do_create);
557 set_internal_unit (dtp, unit, kind);
558 fbuf_init (unit, 128);
559 return unit;
560 }
561
562 /* Has to be an external unit. */
563 dtp->u.p.unit_is_internal = 0;
564 dtp->internal_unit = NULL;
565 dtp->internal_unit_desc = NULL;
566
567 /* For an external unit with unit number < 0 creating it on the fly
568 is not allowed, such units must be created with
569 OPEN(NEWUNIT=...). */
570 if (dtp->common.unit < 0)
571 {
572 if (dtp->common.unit > NEWUNIT_START) /* Reserved units. */
573 return NULL;
574 return get_gfc_unit (dtp->common.unit, 0);
575 }
576
577 return get_gfc_unit (dtp->common.unit, do_create);
578 }
579
580
581 /*************************/
582 /* Initialize everything. */
583
584 void
init_units(void)585 init_units (void)
586 {
587 gfc_unit *u;
588
589 #ifdef HAVE_NEWLOCALE
590 c_locale = newlocale (0, "C", 0);
591 #else
592 #ifndef __GTHREAD_MUTEX_INIT
593 __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
594 #endif
595 #endif
596
597 #ifndef __GTHREAD_MUTEX_INIT
598 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
599 #endif
600
601 if (sizeof (max_offset) == 8)
602 {
603 max_offset = GFC_INTEGER_8_HUGE;
604 /* Why this weird value? Because if the recl specifier in the
605 inquire statement is a 4 byte value, u->recl is truncated,
606 and this trick ensures it becomes HUGE(0) rather than -1.
607 The full 8 byte value of default_recl is still 0.99999999 *
608 max_offset which is large enough for all practical
609 purposes. */
610 default_recl = max_offset & ~(1LL<<31);
611 }
612 else if (sizeof (max_offset) == 4)
613 max_offset = default_recl = GFC_INTEGER_4_HUGE;
614 else
615 internal_error (NULL, "sizeof (max_offset) must be 4 or 8");
616
617 if (options.stdin_unit >= 0)
618 { /* STDIN */
619 u = insert_unit (options.stdin_unit);
620 u->s = input_stream ();
621
622 u->flags.action = ACTION_READ;
623
624 u->flags.access = ACCESS_SEQUENTIAL;
625 u->flags.form = FORM_FORMATTED;
626 u->flags.status = STATUS_OLD;
627 u->flags.blank = BLANK_NULL;
628 u->flags.pad = PAD_YES;
629 u->flags.position = POSITION_ASIS;
630 u->flags.sign = SIGN_PROCDEFINED;
631 u->flags.decimal = DECIMAL_POINT;
632 u->flags.delim = DELIM_UNSPECIFIED;
633 u->flags.encoding = ENCODING_DEFAULT;
634 u->flags.async = ASYNC_NO;
635 u->flags.round = ROUND_PROCDEFINED;
636 u->flags.share = SHARE_UNSPECIFIED;
637 u->flags.cc = CC_LIST;
638
639 u->recl = default_recl;
640 u->endfile = NO_ENDFILE;
641
642 u->filename = strdup (stdin_name);
643
644 fbuf_init (u, 0);
645
646 UNLOCK (&u->lock);
647 }
648
649 if (options.stdout_unit >= 0)
650 { /* STDOUT */
651 u = insert_unit (options.stdout_unit);
652 u->s = output_stream ();
653
654 u->flags.action = ACTION_WRITE;
655
656 u->flags.access = ACCESS_SEQUENTIAL;
657 u->flags.form = FORM_FORMATTED;
658 u->flags.status = STATUS_OLD;
659 u->flags.blank = BLANK_NULL;
660 u->flags.position = POSITION_ASIS;
661 u->flags.sign = SIGN_PROCDEFINED;
662 u->flags.decimal = DECIMAL_POINT;
663 u->flags.delim = DELIM_UNSPECIFIED;
664 u->flags.encoding = ENCODING_DEFAULT;
665 u->flags.async = ASYNC_NO;
666 u->flags.round = ROUND_PROCDEFINED;
667 u->flags.share = SHARE_UNSPECIFIED;
668 u->flags.cc = CC_LIST;
669
670 u->recl = default_recl;
671 u->endfile = AT_ENDFILE;
672
673 u->filename = strdup (stdout_name);
674
675 fbuf_init (u, 0);
676
677 UNLOCK (&u->lock);
678 }
679
680 if (options.stderr_unit >= 0)
681 { /* STDERR */
682 u = insert_unit (options.stderr_unit);
683 u->s = error_stream ();
684
685 u->flags.action = ACTION_WRITE;
686
687 u->flags.access = ACCESS_SEQUENTIAL;
688 u->flags.form = FORM_FORMATTED;
689 u->flags.status = STATUS_OLD;
690 u->flags.blank = BLANK_NULL;
691 u->flags.position = POSITION_ASIS;
692 u->flags.sign = SIGN_PROCDEFINED;
693 u->flags.decimal = DECIMAL_POINT;
694 u->flags.encoding = ENCODING_DEFAULT;
695 u->flags.async = ASYNC_NO;
696 u->flags.round = ROUND_PROCDEFINED;
697 u->flags.share = SHARE_UNSPECIFIED;
698 u->flags.cc = CC_LIST;
699
700 u->recl = default_recl;
701 u->endfile = AT_ENDFILE;
702
703 u->filename = strdup (stderr_name);
704
705 fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
706 any kind of exotic formatting to stderr. */
707
708 UNLOCK (&u->lock);
709 }
710 /* The default internal units. */
711 u = insert_unit (GFC_INTERNAL_UNIT);
712 UNLOCK (&u->lock);
713 u = insert_unit (GFC_INTERNAL_UNIT4);
714 UNLOCK (&u->lock);
715 }
716
717
718 static int
close_unit_1(gfc_unit * u,int locked)719 close_unit_1 (gfc_unit *u, int locked)
720 {
721 int i, rc;
722
723 if (ASYNC_IO && u->au)
724 async_close (u->au);
725
726 /* If there are previously written bytes from a write with ADVANCE="no"
727 Reposition the buffer before closing. */
728 if (u->previous_nonadvancing_write)
729 finish_last_advance_record (u);
730
731 rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
732
733 u->closed = 1;
734 if (!locked)
735 LOCK (&unit_lock);
736
737 for (i = 0; i < CACHE_SIZE; i++)
738 if (unit_cache[i] == u)
739 unit_cache[i] = NULL;
740
741 delete_unit (u);
742
743 free (u->filename);
744 u->filename = NULL;
745
746 free_format_hash_table (u);
747 fbuf_destroy (u);
748
749 if (u->unit_number <= NEWUNIT_START)
750 newunit_free (u->unit_number);
751
752 if (!locked)
753 UNLOCK (&u->lock);
754
755 /* If there are any threads waiting in find_unit for this unit,
756 avoid freeing the memory, the last such thread will free it
757 instead. */
758 if (u->waiting == 0)
759 destroy_unit_mutex (u);
760
761 if (!locked)
762 UNLOCK (&unit_lock);
763
764 return rc;
765 }
766
767 void
unlock_unit(gfc_unit * u)768 unlock_unit (gfc_unit *u)
769 {
770 if (u)
771 {
772 NOTE ("unlock_unit = %d", u->unit_number);
773 UNLOCK (&u->lock);
774 NOTE ("unlock_unit done");
775 }
776 }
777
778 /* close_unit()-- Close a unit. The stream is closed, and any memory
779 associated with the stream is freed. Returns nonzero on I/O error.
780 Should be called with the u->lock locked. */
781
782 int
close_unit(gfc_unit * u)783 close_unit (gfc_unit *u)
784 {
785 return close_unit_1 (u, 0);
786 }
787
788
789 /* close_units()-- Delete units on completion. We just keep deleting
790 the root of the treap until there is nothing left.
791 Not sure what to do with locking here. Some other thread might be
792 holding some unit's lock and perhaps hold it indefinitely
793 (e.g. waiting for input from some pipe) and close_units shouldn't
794 delay the program too much. */
795
796 void
close_units(void)797 close_units (void)
798 {
799 LOCK (&unit_lock);
800 while (unit_root != NULL)
801 close_unit_1 (unit_root, 1);
802 UNLOCK (&unit_lock);
803
804 free (newunits);
805
806 #ifdef HAVE_FREELOCALE
807 freelocale (c_locale);
808 #endif
809 }
810
811
812 /* High level interface to truncate a file, i.e. flush format buffers,
813 and generate an error or set some flags. Just like POSIX
814 ftruncate, returns 0 on success, -1 on failure. */
815
816 int
unit_truncate(gfc_unit * u,gfc_offset pos,st_parameter_common * common)817 unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
818 {
819 int ret;
820
821 /* Make sure format buffer is flushed. */
822 if (u->flags.form == FORM_FORMATTED)
823 {
824 if (u->mode == READING)
825 pos += fbuf_reset (u);
826 else
827 fbuf_flush (u, u->mode);
828 }
829
830 /* struncate() should flush the stream buffer if necessary, so don't
831 bother calling sflush() here. */
832 ret = struncate (u->s, pos);
833
834 if (ret != 0)
835 generate_error (common, LIBERROR_OS, NULL);
836 else
837 {
838 u->endfile = AT_ENDFILE;
839 u->flags.position = POSITION_APPEND;
840 }
841
842 return ret;
843 }
844
845
846 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
847 name of the associated file, otherwise return the empty string. The caller
848 must free memory allocated for the filename string. */
849
850 char *
filename_from_unit(int n)851 filename_from_unit (int n)
852 {
853 gfc_unit *u;
854 int c;
855
856 /* Find the unit. */
857 u = unit_root;
858 while (u != NULL)
859 {
860 c = compare (n, u->unit_number);
861 if (c < 0)
862 u = u->left;
863 if (c > 0)
864 u = u->right;
865 if (c == 0)
866 break;
867 }
868
869 /* Get the filename. */
870 if (u != NULL && u->filename != NULL)
871 return strdup (u->filename);
872 else
873 return (char *) NULL;
874 }
875
876 void
finish_last_advance_record(gfc_unit * u)877 finish_last_advance_record (gfc_unit *u)
878 {
879
880 if (u->saved_pos > 0)
881 fbuf_seek (u, u->saved_pos, SEEK_CUR);
882
883 if (!(u->unit_number == options.stdout_unit
884 || u->unit_number == options.stderr_unit))
885 {
886 #ifdef HAVE_CRLF
887 const int len = 2;
888 #else
889 const int len = 1;
890 #endif
891 char *p = fbuf_alloc (u, len);
892 if (!p)
893 os_error ("Completing record after ADVANCE_NO failed");
894 #ifdef HAVE_CRLF
895 *(p++) = '\r';
896 #endif
897 *p = '\n';
898 }
899
900 fbuf_flush (u, u->mode);
901 }
902
903
904 /* Assign a negative number for NEWUNIT in OPEN statements or for
905 internal units. */
906 int
newunit_alloc(void)907 newunit_alloc (void)
908 {
909 LOCK (&unit_lock);
910 if (!newunits)
911 {
912 newunits = xcalloc (16, 1);
913 newunit_size = 16;
914 }
915
916 /* Search for the next available newunit. */
917 for (int ii = newunit_lwi; ii < newunit_size; ii++)
918 {
919 if (!newunits[ii])
920 {
921 newunits[ii] = true;
922 newunit_lwi = ii + 1;
923 UNLOCK (&unit_lock);
924 return -ii + NEWUNIT_START;
925 }
926 }
927
928 /* Search failed, bump size of array and allocate the first
929 available unit. */
930 int old_size = newunit_size;
931 newunit_size *= 2;
932 newunits = xrealloc (newunits, newunit_size);
933 memset (newunits + old_size, 0, old_size);
934 newunits[old_size] = true;
935 newunit_lwi = old_size + 1;
936 UNLOCK (&unit_lock);
937 return -old_size + NEWUNIT_START;
938 }
939
940
941 /* Free a previously allocated newunit= unit number. unit_lock must
942 be held when calling. */
943
944 void
newunit_free(int unit)945 newunit_free (int unit)
946 {
947 int ind = -unit + NEWUNIT_START;
948 assert(ind >= 0 && ind < newunit_size);
949 newunits[ind] = false;
950 if (ind < newunit_lwi)
951 newunit_lwi = ind;
952 }
953