1 /* Copyright (C) 2002-2023 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_POSIX_2008_LOCALE
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
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 *
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 *
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
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 *
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 *
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
254 destroy_unit_mutex (gfc_unit *u)
255 {
256 __gthread_mutex_destroy (&u->lock);
257 free (u);
258 }
259
260
261 static gfc_unit *
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 *
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
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 *
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 *
412 find_unit (int n)
413 {
414 return get_gfc_unit (n, 0);
415 }
416
417
418 gfc_unit *
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
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 *
455 set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
456 {
457 gfc_offset start_record = 0;
458
459 iunit->recl = dtp->internal_unit_len;
460 iunit->internal_unit = dtp->internal_unit;
461 iunit->internal_unit_len = dtp->internal_unit_len;
462 iunit->internal_unit_kind = kind;
463
464 /* As an optimization, adjust the unit record length to not
465 include trailing blanks. This will not work under certain conditions
466 where trailing blanks have significance. */
467 if (dtp->u.p.mode == READING && is_trim_ok (dtp))
468 {
469 int len;
470 if (kind == 1)
471 len = string_len_trim (iunit->internal_unit_len,
472 iunit->internal_unit);
473 else
474 len = string_len_trim_char4 (iunit->internal_unit_len,
475 (const gfc_char4_t*) iunit->internal_unit);
476 iunit->internal_unit_len = len;
477 iunit->recl = iunit->internal_unit_len;
478 }
479
480 /* Set up the looping specification from the array descriptor, if any. */
481
482 if (is_array_io (dtp))
483 {
484 iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
485 iunit->ls = (array_loop_spec *)
486 xmallocarray (iunit->rank, sizeof (array_loop_spec));
487 iunit->internal_unit_len *=
488 init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
489
490 start_record *= iunit->recl;
491 }
492
493 /* Set initial values for unit parameters. */
494 if (kind == 4)
495 iunit->s = open_internal4 (iunit->internal_unit - start_record,
496 iunit->internal_unit_len, -start_record);
497 else
498 iunit->s = open_internal (iunit->internal_unit - start_record,
499 iunit->internal_unit_len, -start_record);
500
501 iunit->bytes_left = iunit->recl;
502 iunit->last_record=0;
503 iunit->maxrec=0;
504 iunit->current_record=0;
505 iunit->read_bad = 0;
506 iunit->endfile = NO_ENDFILE;
507
508 /* Set flags for the internal unit. */
509
510 iunit->flags.access = ACCESS_SEQUENTIAL;
511 iunit->flags.action = ACTION_READWRITE;
512 iunit->flags.blank = BLANK_NULL;
513 iunit->flags.form = FORM_FORMATTED;
514 iunit->flags.pad = PAD_YES;
515 iunit->flags.status = STATUS_UNSPECIFIED;
516 iunit->flags.sign = SIGN_PROCDEFINED;
517 iunit->flags.decimal = DECIMAL_POINT;
518 iunit->flags.delim = DELIM_UNSPECIFIED;
519 iunit->flags.encoding = ENCODING_DEFAULT;
520 iunit->flags.async = ASYNC_NO;
521 iunit->flags.round = ROUND_PROCDEFINED;
522
523 /* Initialize the data transfer parameters. */
524
525 dtp->u.p.advance_status = ADVANCE_YES;
526 dtp->u.p.seen_dollar = 0;
527 dtp->u.p.skips = 0;
528 dtp->u.p.pending_spaces = 0;
529 dtp->u.p.max_pos = 0;
530 dtp->u.p.at_eof = 0;
531 return iunit;
532 }
533
534
535 /* get_unit()-- Returns the unit structure associated with the integer
536 unit or the internal file. */
537
538 gfc_unit *
539 get_unit (st_parameter_dt *dtp, int do_create)
540 {
541 gfc_unit *unit;
542
543 if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
544 {
545 int kind;
546 if (dtp->common.unit == GFC_INTERNAL_UNIT)
547 kind = 1;
548 else if (dtp->common.unit == GFC_INTERNAL_UNIT4)
549 kind = 4;
550 else
551 internal_error (&dtp->common, "get_unit(): Bad internal unit KIND");
552
553 dtp->u.p.unit_is_internal = 1;
554 dtp->common.unit = newunit_alloc ();
555 unit = get_gfc_unit (dtp->common.unit, do_create);
556 set_internal_unit (dtp, unit, kind);
557 fbuf_init (unit, 128);
558 return unit;
559 }
560
561 /* Has to be an external unit. */
562 dtp->u.p.unit_is_internal = 0;
563 dtp->internal_unit = NULL;
564 dtp->internal_unit_desc = NULL;
565
566 /* For an external unit with unit number < 0 creating it on the fly
567 is not allowed, such units must be created with
568 OPEN(NEWUNIT=...). */
569 if (dtp->common.unit < 0)
570 {
571 if (dtp->common.unit > NEWUNIT_START) /* Reserved units. */
572 return NULL;
573 return get_gfc_unit (dtp->common.unit, 0);
574 }
575
576 return get_gfc_unit (dtp->common.unit, do_create);
577 }
578
579
580 /*************************/
581 /* Initialize everything. */
582
583 void
584 init_units (void)
585 {
586 gfc_unit *u;
587
588 #ifdef HAVE_POSIX_2008_LOCALE
589 c_locale = newlocale (0, "C", 0);
590 #else
591 #ifndef __GTHREAD_MUTEX_INIT
592 __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
593 #endif
594 #endif
595
596 #ifndef __GTHREAD_MUTEX_INIT
597 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
598 #endif
599
600 if (sizeof (max_offset) == 8)
601 {
602 max_offset = GFC_INTEGER_8_HUGE;
603 /* Why this weird value? Because if the recl specifier in the
604 inquire statement is a 4 byte value, u->recl is truncated,
605 and this trick ensures it becomes HUGE(0) rather than -1.
606 The full 8 byte value of default_recl is still 0.99999999 *
607 max_offset which is large enough for all practical
608 purposes. */
609 default_recl = max_offset & ~(1LL<<31);
610 }
611 else if (sizeof (max_offset) == 4)
612 max_offset = default_recl = GFC_INTEGER_4_HUGE;
613 else
614 internal_error (NULL, "sizeof (max_offset) must be 4 or 8");
615
616 if (options.stdin_unit >= 0)
617 { /* STDIN */
618 u = insert_unit (options.stdin_unit);
619 u->s = input_stream ();
620
621 u->flags.action = ACTION_READ;
622
623 u->flags.access = ACCESS_SEQUENTIAL;
624 u->flags.form = FORM_FORMATTED;
625 u->flags.status = STATUS_OLD;
626 u->flags.blank = BLANK_NULL;
627 u->flags.pad = PAD_YES;
628 u->flags.position = POSITION_ASIS;
629 u->flags.sign = SIGN_PROCDEFINED;
630 u->flags.decimal = DECIMAL_POINT;
631 u->flags.delim = DELIM_UNSPECIFIED;
632 u->flags.encoding = ENCODING_DEFAULT;
633 u->flags.async = ASYNC_NO;
634 u->flags.round = ROUND_PROCDEFINED;
635 u->flags.share = SHARE_UNSPECIFIED;
636 u->flags.cc = CC_LIST;
637
638 u->recl = default_recl;
639 u->endfile = NO_ENDFILE;
640
641 u->filename = strdup (stdin_name);
642
643 fbuf_init (u, 0);
644
645 UNLOCK (&u->lock);
646 }
647
648 if (options.stdout_unit >= 0)
649 { /* STDOUT */
650 u = insert_unit (options.stdout_unit);
651 u->s = output_stream ();
652
653 u->flags.action = ACTION_WRITE;
654
655 u->flags.access = ACCESS_SEQUENTIAL;
656 u->flags.form = FORM_FORMATTED;
657 u->flags.status = STATUS_OLD;
658 u->flags.blank = BLANK_NULL;
659 u->flags.position = POSITION_ASIS;
660 u->flags.sign = SIGN_PROCDEFINED;
661 u->flags.decimal = DECIMAL_POINT;
662 u->flags.delim = DELIM_UNSPECIFIED;
663 u->flags.encoding = ENCODING_DEFAULT;
664 u->flags.async = ASYNC_NO;
665 u->flags.round = ROUND_PROCDEFINED;
666 u->flags.share = SHARE_UNSPECIFIED;
667 u->flags.cc = CC_LIST;
668
669 u->recl = default_recl;
670 u->endfile = AT_ENDFILE;
671
672 u->filename = strdup (stdout_name);
673
674 fbuf_init (u, 0);
675
676 UNLOCK (&u->lock);
677 }
678
679 if (options.stderr_unit >= 0)
680 { /* STDERR */
681 u = insert_unit (options.stderr_unit);
682 u->s = error_stream ();
683
684 u->flags.action = ACTION_WRITE;
685
686 u->flags.access = ACCESS_SEQUENTIAL;
687 u->flags.form = FORM_FORMATTED;
688 u->flags.status = STATUS_OLD;
689 u->flags.blank = BLANK_NULL;
690 u->flags.position = POSITION_ASIS;
691 u->flags.sign = SIGN_PROCDEFINED;
692 u->flags.decimal = DECIMAL_POINT;
693 u->flags.encoding = ENCODING_DEFAULT;
694 u->flags.async = ASYNC_NO;
695 u->flags.round = ROUND_PROCDEFINED;
696 u->flags.share = SHARE_UNSPECIFIED;
697 u->flags.cc = CC_LIST;
698
699 u->recl = default_recl;
700 u->endfile = AT_ENDFILE;
701
702 u->filename = strdup (stderr_name);
703
704 fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
705 any kind of exotic formatting to stderr. */
706
707 UNLOCK (&u->lock);
708 }
709 /* The default internal units. */
710 u = insert_unit (GFC_INTERNAL_UNIT);
711 UNLOCK (&u->lock);
712 u = insert_unit (GFC_INTERNAL_UNIT4);
713 UNLOCK (&u->lock);
714 }
715
716
717 static int
718 close_unit_1 (gfc_unit *u, int locked)
719 {
720 int i, rc;
721
722 if (ASYNC_IO && u->au)
723 async_close (u->au);
724
725 /* If there are previously written bytes from a write with ADVANCE="no"
726 Reposition the buffer before closing. */
727 if (u->previous_nonadvancing_write)
728 finish_last_advance_record (u);
729
730 rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
731
732 u->closed = 1;
733 if (!locked)
734 LOCK (&unit_lock);
735
736 for (i = 0; i < CACHE_SIZE; i++)
737 if (unit_cache[i] == u)
738 unit_cache[i] = NULL;
739
740 delete_unit (u);
741
742 free (u->filename);
743 u->filename = NULL;
744
745 free_format_hash_table (u);
746 fbuf_destroy (u);
747
748 if (u->unit_number <= NEWUNIT_START)
749 newunit_free (u->unit_number);
750
751 if (!locked)
752 UNLOCK (&u->lock);
753
754 /* If there are any threads waiting in find_unit for this unit,
755 avoid freeing the memory, the last such thread will free it
756 instead. */
757 if (u->waiting == 0)
758 destroy_unit_mutex (u);
759
760 if (!locked)
761 UNLOCK (&unit_lock);
762
763 return rc;
764 }
765
766 void
767 unlock_unit (gfc_unit *u)
768 {
769 if (u)
770 {
771 NOTE ("unlock_unit = %d", u->unit_number);
772 UNLOCK (&u->lock);
773 NOTE ("unlock_unit done");
774 }
775 }
776
777 /* close_unit()-- Close a unit. The stream is closed, and any memory
778 associated with the stream is freed. Returns nonzero on I/O error.
779 Should be called with the u->lock locked. */
780
781 int
782 close_unit (gfc_unit *u)
783 {
784 return close_unit_1 (u, 0);
785 }
786
787
788 /* close_units()-- Delete units on completion. We just keep deleting
789 the root of the treap until there is nothing left.
790 Not sure what to do with locking here. Some other thread might be
791 holding some unit's lock and perhaps hold it indefinitely
792 (e.g. waiting for input from some pipe) and close_units shouldn't
793 delay the program too much. */
794
795 void
796 close_units (void)
797 {
798 LOCK (&unit_lock);
799 while (unit_root != NULL)
800 close_unit_1 (unit_root, 1);
801 UNLOCK (&unit_lock);
802
803 free (newunits);
804
805 #ifdef HAVE_POSIX_2008_LOCALE
806 freelocale (c_locale);
807 #endif
808 }
809
810
811 /* High level interface to truncate a file, i.e. flush format buffers,
812 and generate an error or set some flags. Just like POSIX
813 ftruncate, returns 0 on success, -1 on failure. */
814
815 int
816 unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
817 {
818 int ret;
819
820 /* Make sure format buffer is flushed. */
821 if (u->flags.form == FORM_FORMATTED)
822 {
823 if (u->mode == READING)
824 pos += fbuf_reset (u);
825 else
826 fbuf_flush (u, u->mode);
827 }
828
829 /* struncate() should flush the stream buffer if necessary, so don't
830 bother calling sflush() here. */
831 ret = struncate (u->s, pos);
832
833 if (ret != 0)
834 generate_error (common, LIBERROR_OS, NULL);
835 else
836 {
837 u->endfile = AT_ENDFILE;
838 u->flags.position = POSITION_APPEND;
839 }
840
841 return ret;
842 }
843
844
845 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
846 name of the associated file, otherwise return the empty string. The caller
847 must free memory allocated for the filename string. */
848
849 char *
850 filename_from_unit (int n)
851 {
852 gfc_unit *u;
853 int c;
854
855 /* Find the unit. */
856 u = unit_root;
857 while (u != NULL)
858 {
859 c = compare (n, u->unit_number);
860 if (c < 0)
861 u = u->left;
862 if (c > 0)
863 u = u->right;
864 if (c == 0)
865 break;
866 }
867
868 /* Get the filename. */
869 if (u != NULL && u->filename != NULL)
870 return strdup (u->filename);
871 else
872 return (char *) NULL;
873 }
874
875 void
876 finish_last_advance_record (gfc_unit *u)
877 {
878
879 if (u->saved_pos > 0)
880 fbuf_seek (u, u->saved_pos, SEEK_CUR);
881
882 if (!(u->unit_number == options.stdout_unit
883 || u->unit_number == options.stderr_unit))
884 {
885 #ifdef HAVE_CRLF
886 const int len = 2;
887 #else
888 const int len = 1;
889 #endif
890 char *p = fbuf_alloc (u, len);
891 if (!p)
892 os_error ("Completing record after ADVANCE_NO failed");
893 #ifdef HAVE_CRLF
894 *(p++) = '\r';
895 #endif
896 *p = '\n';
897 }
898
899 fbuf_flush (u, u->mode);
900 }
901
902
903 /* Assign a negative number for NEWUNIT in OPEN statements or for
904 internal units. */
905 int
906 newunit_alloc (void)
907 {
908 LOCK (&unit_lock);
909 if (!newunits)
910 {
911 newunits = xcalloc (16, 1);
912 newunit_size = 16;
913 }
914
915 /* Search for the next available newunit. */
916 for (int ii = newunit_lwi; ii < newunit_size; ii++)
917 {
918 if (!newunits[ii])
919 {
920 newunits[ii] = true;
921 newunit_lwi = ii + 1;
922 UNLOCK (&unit_lock);
923 return -ii + NEWUNIT_START;
924 }
925 }
926
927 /* Search failed, bump size of array and allocate the first
928 available unit. */
929 int old_size = newunit_size;
930 newunit_size *= 2;
931 newunits = xrealloc (newunits, newunit_size);
932 memset (newunits + old_size, 0, old_size);
933 newunits[old_size] = true;
934 newunit_lwi = old_size + 1;
935 UNLOCK (&unit_lock);
936 return -old_size + NEWUNIT_START;
937 }
938
939
940 /* Free a previously allocated newunit= unit number. unit_lock must
941 be held when calling. */
942
943 void
944 newunit_free (int unit)
945 {
946 int ind = -unit + NEWUNIT_START;
947 assert(ind >= 0 && ind < newunit_size);
948 newunits[ind] = false;
949 if (ind < newunit_lwi)
950 newunit_lwi = ind;
951 }