1 /* Copyright (C) 2002-2024 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran runtime library (libgfortran).
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)
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.
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.
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/>. */
36 UNIT_RWLOCK is a master rw lock, protecting UNIT_ROOT tree and UNIT_CACHE.
37 Using an rwlock improves efficiency by allowing us to separate readers
38 and writers of both UNIT_ROOT and UNIT_CACHE.
39 Concurrent use of different units should be supported, so
40 each unit has its own lock, LOCK.
41 Open should be atomic with its reopening of units and list_read.c
42 in several places needs find_unit another unit while holding stdin
43 unit's lock, so it must be possible to acquire UNIT_RWLOCK while holding
44 some unit's lock. Therefore to avoid deadlocks, it is forbidden
45 to acquire unit's private locks while holding UNIT_RWLOCK, except
46 for freshly created units (where no other thread can get at their
47 address yet) or when using just trylock rather than lock operation.
48 In addition to unit's private lock each unit has a WAITERS counter
49 and CLOSED flag. WAITERS counter must be either only
50 atomically incremented/decremented in all places (if atomic builtins
51 are supported), or protected by UNIT_RWLOCK in all places (otherwise).
52 CLOSED flag must be always protected by unit's LOCK.
53 After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_RWLOCK held,
54 WAITERS must be incremented to avoid concurrent close from freeing
55 the unit between unlocking UNIT_RWLOCK and acquiring unit's LOCK.
56 Unit freeing is always done under UNIT_RWLOCK. If close_unit sees any
57 WAITERS, it doesn't free the unit but instead sets the CLOSED flag
58 and the thread that decrements WAITERS to zero while CLOSED flag is
59 set is responsible for freeing it (while holding UNIT_RWLOCK).
60 flush_all_units operation is iterating over the unit tree with
61 increasing UNIT_NUMBER while holding UNIT_RWLOCK and attempting to
62 flush each unit (and therefore needs the unit's LOCK held as well).
63 To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
64 remembers the current unit's UNIT_NUMBER, unlocks UNIT_RWLOCK, acquires
65 unit's LOCK and after flushing reacquires UNIT_RWLOCK and restarts with
66 the smallest UNIT_NUMBER above the last one flushed.
68 If find_unit/find_or_create_unit/find_file/get_unit routines return
69 non-NULL, the returned unit has its private lock locked and when the
70 caller is done with it, it must call either unlock_unit or close_unit
71 on it. unlock_unit or close_unit must be always called only with the
76 /* Table of allocated newunit values. A simple solution would be to
77 map OS file descriptors (fd's) to unit numbers, e.g. with newunit =
78 -fd - 2, however that doesn't work since Fortran allows an existing
79 unit number to be reassociated with a new file. Thus the simple
80 approach may lead to a situation where we'd try to assign a
81 (negative) unit number which already exists. Hence we must keep
82 track of allocated newunit values ourselves. This is the purpose of
83 the newunits array. The indices map to newunit values as newunit =
84 -index + NEWUNIT_FIRST. E.g. newunits[0] having the value true
85 means that a unit with number NEWUNIT_FIRST exists. Similar to
86 POSIX file descriptors, we always allocate the lowest (in absolute
87 value) available unit number.
89 static bool *newunits
;
90 static int newunit_size
; /* Total number of elements in the newunits array. */
91 /* Low water indicator for the newunits array. Below the LWI all the
92 units are allocated, above and equal to the LWI there may be both
93 allocated and free units. */
94 static int newunit_lwi
;
96 /* Unit numbers assigned with NEWUNIT start from here. */
97 #define NEWUNIT_START -10
100 static gfc_unit
*unit_cache
[CACHE_SIZE
];
102 gfc_offset max_offset
;
103 gfc_offset default_recl
;
106 #ifdef __GTHREAD_RWLOCK_INIT
107 __gthread_rwlock_t unit_rwlock
= __GTHREAD_RWLOCK_INIT
;
109 #ifdef __GTHREAD_MUTEX_INIT
110 __gthread_mutex_t unit_rwlock
= __GTHREAD_MUTEX_INIT
;
112 __gthread_mutex_t unit_rwlock
;
116 /* We use these filenames for error reporting. */
118 static char stdin_name
[] = "stdin";
119 static char stdout_name
[] = "stdout";
120 static char stderr_name
[] = "stderr";
123 #ifdef HAVE_POSIX_2008_LOCALE
126 /* If we don't have POSIX 2008 per-thread locales, we need to use the
127 traditional setlocale(). To prevent multiple concurrent threads
128 doing formatted I/O from messing up the locale, we need to store a
129 global old_locale, and a counter keeping track of how many threads
130 are currently doing formatted I/O. The first thread saves the old
131 locale, and the last one restores it. */
134 #ifdef __GTHREAD_MUTEX_INIT
135 __gthread_mutex_t old_locale_lock
= __GTHREAD_MUTEX_INIT
;
137 __gthread_mutex_t old_locale_lock
;
142 /* This implementation is based on Stefan Nilsson's article in the
143 July 1997 Doctor Dobb's Journal, "Treaps in Java". */
145 /* pseudo_random()-- Simple linear congruential pseudorandom number
146 generator. The period of this generator is 44071, which is plenty
152 static int x0
= 5341;
154 x0
= (22611 * x0
+ 10) % 44071;
159 /* rotate_left()-- Rotate the treap left */
162 rotate_left (gfc_unit
*t
)
167 t
->right
= t
->right
->left
;
174 /* rotate_right()-- Rotate the treap right */
177 rotate_right (gfc_unit
*t
)
182 t
->left
= t
->left
->right
;
190 compare (int a
, int b
)
201 /* insert()-- Recursive insertion function. Returns the updated treap. */
204 insert (gfc_unit
*new, gfc_unit
*t
)
211 c
= compare (new->unit_number
, t
->unit_number
);
215 t
->left
= insert (new, t
->left
);
216 if (t
->priority
< t
->left
->priority
)
217 t
= rotate_right (t
);
222 t
->right
= insert (new, t
->right
);
223 if (t
->priority
< t
->right
->priority
)
228 internal_error (NULL
, "insert(): Duplicate key found!");
234 /* insert_unit()-- Create a new node, insert it into the treap. */
239 gfc_unit
*u
= xcalloc (1, sizeof (gfc_unit
));
241 u
->internal_unit_kind
= 0;
242 #ifdef __GTHREAD_MUTEX_INIT
244 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
248 __GTHREAD_MUTEX_INIT_FUNCTION (&u
->lock
);
251 u
->priority
= pseudo_random ();
252 unit_root
= insert (u
, unit_root
);
257 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
260 destroy_unit_mutex (gfc_unit
*u
)
262 __gthread_mutex_destroy (&u
->lock
);
268 delete_root (gfc_unit
*t
)
274 if (t
->right
== NULL
)
277 if (t
->left
->priority
> t
->right
->priority
)
279 temp
= rotate_right (t
);
280 temp
->right
= delete_root (t
);
284 temp
= rotate_left (t
);
285 temp
->left
= delete_root (t
);
292 /* delete_treap()-- Delete an element from a tree. The 'old' value
293 does not necessarily have to point to the element to be deleted, it
294 must just point to a treap structure with the key to be deleted.
295 Returns the new root node of the tree. */
298 delete_treap (gfc_unit
*old
, gfc_unit
*t
)
305 c
= compare (old
->unit_number
, t
->unit_number
);
308 t
->left
= delete_treap (old
, t
->left
);
310 t
->right
= delete_treap (old
, t
->right
);
318 /* delete_unit()-- Delete a unit from a tree */
321 delete_unit (gfc_unit
*old
)
323 unit_root
= delete_treap (old
, unit_root
);
326 /* get_gfc_unit_from_root()-- Given an integer, return a pointer
327 to the unit structure. Returns NULL if the unit does not exist,
328 otherwise returns a locked unit. */
330 static inline gfc_unit
*
331 get_gfc_unit_from_unit_root (int n
)
338 c
= compare (n
, p
->unit_number
);
349 /* get_gfc_unit()-- Given an integer, return a pointer to the unit
350 structure. Returns NULL if the unit does not exist,
351 otherwise returns a locked unit. */
354 get_gfc_unit (int n
, int do_create
)
359 NOTE ("Unit n=%d, do_create = %d", n
, do_create
);
360 RDLOCK (&unit_rwlock
);
363 for (c
= 0; c
< CACHE_SIZE
; c
++)
364 if (unit_cache
[c
] != NULL
&& unit_cache
[c
]->unit_number
== n
)
370 p
= get_gfc_unit_from_unit_root (n
);
372 /* We did not find a unit in the cache nor in the unit list,
373 create a new (locked) unit and insert into the unit list and
374 cache. Manipulating either or both the unit list and the unit
375 cache requires to hold a write-lock [for obvious reasons]:
376 By separating the read/write lock, we will greatly reduce
377 the contention on the read part, while the write part is
378 unlikely once the unit hits the cache. */
379 RD_TO_WRLOCK (&unit_rwlock
);
381 /* In the case of high concurrency, when multiple threads want
382 to find or create the same unit, the unit number may not
383 exist in cache nor in the unit list during read phase, then
384 threads will acquire the write-lock to insert the same unit
385 number to unit list. To avoid duplicate insert, we need to
386 find unit list once again to ensure that the unit number
388 p
= get_gfc_unit_from_unit_root (n
);
389 if (p
== NULL
&& do_create
)
397 for (c
= 0; c
< CACHE_SIZE
- 1; c
++)
398 unit_cache
[c
] = unit_cache
[c
+ 1];
400 unit_cache
[CACHE_SIZE
- 1] = p
;
405 /* Newly created units have their lock held already
406 from insert_unit. Just unlock UNIT_RWLOCK and return. */
407 RWUNLOCK (&unit_rwlock
);
412 if (p
!= NULL
&& (p
->child_dtio
== 0))
415 if (! TRYLOCK (&p
->lock
))
417 /* assert (p->closed == 0); */
418 RWUNLOCK (&unit_rwlock
);
422 inc_waiting_locked (p
);
426 RWUNLOCK (&unit_rwlock
);
428 if (p
!= NULL
&& (p
->child_dtio
== 0))
433 WRLOCK (&unit_rwlock
);
435 if (predec_waiting_locked (p
) == 0)
436 destroy_unit_mutex (p
);
440 dec_waiting_unlocked (p
);
449 return get_gfc_unit (n
, 0);
454 find_or_create_unit (int n
)
456 return get_gfc_unit (n
, 1);
460 /* Helper function to check rank, stride, format string, and namelist.
461 This is used for optimization. You can't trim out blanks or shorten
462 the string if trailing spaces are significant. */
464 is_trim_ok (st_parameter_dt
*dtp
)
466 /* Check rank and stride. */
467 if (dtp
->internal_unit_desc
)
469 /* Format strings cannot have 'BZ' or '/'. */
470 if (dtp
->common
.flags
& IOPARM_DT_HAS_FORMAT
)
472 char *p
= dtp
->format
;
473 if (dtp
->common
.flags
& IOPARM_DT_HAS_BLANK
)
475 for (gfc_charlen_type i
= 0; i
< dtp
->format_len
; i
++)
477 if (p
[i
] == '/') return false;
478 if (p
[i
] == 'b' || p
[i
] == 'B')
479 if (p
[i
+1] == 'z' || p
[i
+1] == 'Z')
483 if (dtp
->u
.p
.ionml
) /* A namelist. */
490 set_internal_unit (st_parameter_dt
*dtp
, gfc_unit
*iunit
, int kind
)
492 gfc_offset start_record
= 0;
494 iunit
->recl
= dtp
->internal_unit_len
;
495 iunit
->internal_unit
= dtp
->internal_unit
;
496 iunit
->internal_unit_len
= dtp
->internal_unit_len
;
497 iunit
->internal_unit_kind
= kind
;
499 /* As an optimization, adjust the unit record length to not
500 include trailing blanks. This will not work under certain conditions
501 where trailing blanks have significance. */
502 if (dtp
->u
.p
.mode
== READING
&& is_trim_ok (dtp
))
506 len
= string_len_trim (iunit
->internal_unit_len
,
507 iunit
->internal_unit
);
509 len
= string_len_trim_char4 (iunit
->internal_unit_len
,
510 (const gfc_char4_t
*) iunit
->internal_unit
);
511 iunit
->internal_unit_len
= len
;
512 iunit
->recl
= iunit
->internal_unit_len
;
515 /* Set up the looping specification from the array descriptor, if any. */
517 if (is_array_io (dtp
))
519 iunit
->rank
= GFC_DESCRIPTOR_RANK (dtp
->internal_unit_desc
);
520 iunit
->ls
= (array_loop_spec
*)
521 xmallocarray (iunit
->rank
, sizeof (array_loop_spec
));
522 iunit
->internal_unit_len
*=
523 init_loop_spec (dtp
->internal_unit_desc
, iunit
->ls
, &start_record
);
525 start_record
*= iunit
->recl
;
528 /* Set initial values for unit parameters. */
530 iunit
->s
= open_internal4 (iunit
->internal_unit
- start_record
,
531 iunit
->internal_unit_len
, -start_record
);
533 iunit
->s
= open_internal (iunit
->internal_unit
- start_record
,
534 iunit
->internal_unit_len
, -start_record
);
536 iunit
->bytes_left
= iunit
->recl
;
537 iunit
->last_record
=0;
539 iunit
->current_record
=0;
541 iunit
->endfile
= NO_ENDFILE
;
542 iunit
->last_char
= 0;
544 /* Set flags for the internal unit. */
546 iunit
->flags
.access
= ACCESS_SEQUENTIAL
;
547 iunit
->flags
.action
= ACTION_READWRITE
;
548 iunit
->flags
.blank
= BLANK_NULL
;
549 iunit
->flags
.form
= FORM_FORMATTED
;
550 iunit
->flags
.pad
= PAD_YES
;
551 iunit
->flags
.status
= STATUS_UNSPECIFIED
;
552 iunit
->flags
.sign
= SIGN_PROCDEFINED
;
553 iunit
->flags
.decimal
= DECIMAL_POINT
;
554 iunit
->flags
.delim
= DELIM_UNSPECIFIED
;
555 iunit
->flags
.encoding
= ENCODING_DEFAULT
;
556 iunit
->flags
.async
= ASYNC_NO
;
557 iunit
->flags
.round
= ROUND_PROCDEFINED
;
559 /* Initialize the data transfer parameters. */
561 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
562 dtp
->u
.p
.seen_dollar
= 0;
564 dtp
->u
.p
.pending_spaces
= 0;
565 dtp
->u
.p
.max_pos
= 0;
571 /* get_unit()-- Returns the unit structure associated with the integer
572 unit or the internal file. */
575 get_unit (st_parameter_dt
*dtp
, int do_create
)
579 if ((dtp
->common
.flags
& IOPARM_DT_HAS_INTERNAL_UNIT
) != 0)
582 if (dtp
->common
.unit
== GFC_INTERNAL_UNIT
)
584 else if (dtp
->common
.unit
== GFC_INTERNAL_UNIT4
)
587 internal_error (&dtp
->common
, "get_unit(): Bad internal unit KIND");
589 dtp
->u
.p
.unit_is_internal
= 1;
590 dtp
->common
.unit
= newunit_alloc ();
591 unit
= get_gfc_unit (dtp
->common
.unit
, do_create
);
592 set_internal_unit (dtp
, unit
, kind
);
593 fbuf_init (unit
, 128);
597 /* Has to be an external unit. */
598 dtp
->u
.p
.unit_is_internal
= 0;
599 dtp
->internal_unit
= NULL
;
600 dtp
->internal_unit_desc
= NULL
;
602 /* For an external unit with unit number < 0 creating it on the fly
603 is not allowed, such units must be created with
604 OPEN(NEWUNIT=...). */
605 if (dtp
->common
.unit
< 0)
607 if (dtp
->common
.unit
> NEWUNIT_START
) /* Reserved units. */
609 return get_gfc_unit (dtp
->common
.unit
, 0);
612 return get_gfc_unit (dtp
->common
.unit
, do_create
);
616 /*************************/
617 /* Initialize everything. */
624 #ifdef HAVE_POSIX_2008_LOCALE
625 c_locale
= newlocale (0, "C", 0);
627 #ifndef __GTHREAD_MUTEX_INIT
628 __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock
);
632 #if (!defined(__GTHREAD_RWLOCK_INIT) && !defined(__GTHREAD_MUTEX_INIT))
633 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_rwlock
);
636 if (sizeof (max_offset
) == 8)
638 max_offset
= GFC_INTEGER_8_HUGE
;
639 /* Why this weird value? Because if the recl specifier in the
640 inquire statement is a 4 byte value, u->recl is truncated,
641 and this trick ensures it becomes HUGE(0) rather than -1.
642 The full 8 byte value of default_recl is still 0.99999999 *
643 max_offset which is large enough for all practical
645 default_recl
= max_offset
& ~(1LL<<31);
647 else if (sizeof (max_offset
) == 4)
648 max_offset
= default_recl
= GFC_INTEGER_4_HUGE
;
650 internal_error (NULL
, "sizeof (max_offset) must be 4 or 8");
652 if (options
.stdin_unit
>= 0)
654 u
= insert_unit (options
.stdin_unit
);
655 u
->s
= input_stream ();
657 u
->flags
.action
= ACTION_READ
;
659 u
->flags
.access
= ACCESS_SEQUENTIAL
;
660 u
->flags
.form
= FORM_FORMATTED
;
661 u
->flags
.status
= STATUS_OLD
;
662 u
->flags
.blank
= BLANK_NULL
;
663 u
->flags
.pad
= PAD_YES
;
664 u
->flags
.position
= POSITION_ASIS
;
665 u
->flags
.sign
= SIGN_PROCDEFINED
;
666 u
->flags
.decimal
= DECIMAL_POINT
;
667 u
->flags
.delim
= DELIM_UNSPECIFIED
;
668 u
->flags
.encoding
= ENCODING_DEFAULT
;
669 u
->flags
.async
= ASYNC_NO
;
670 u
->flags
.round
= ROUND_PROCDEFINED
;
671 u
->flags
.share
= SHARE_UNSPECIFIED
;
672 u
->flags
.cc
= CC_LIST
;
674 u
->recl
= default_recl
;
675 u
->endfile
= NO_ENDFILE
;
677 u
->filename
= strdup (stdin_name
);
684 if (options
.stdout_unit
>= 0)
686 u
= insert_unit (options
.stdout_unit
);
687 u
->s
= output_stream ();
689 u
->flags
.action
= ACTION_WRITE
;
691 u
->flags
.access
= ACCESS_SEQUENTIAL
;
692 u
->flags
.form
= FORM_FORMATTED
;
693 u
->flags
.status
= STATUS_OLD
;
694 u
->flags
.blank
= BLANK_NULL
;
695 u
->flags
.position
= POSITION_ASIS
;
696 u
->flags
.sign
= SIGN_PROCDEFINED
;
697 u
->flags
.decimal
= DECIMAL_POINT
;
698 u
->flags
.delim
= DELIM_UNSPECIFIED
;
699 u
->flags
.encoding
= ENCODING_DEFAULT
;
700 u
->flags
.async
= ASYNC_NO
;
701 u
->flags
.round
= ROUND_PROCDEFINED
;
702 u
->flags
.share
= SHARE_UNSPECIFIED
;
703 u
->flags
.cc
= CC_LIST
;
705 u
->recl
= default_recl
;
706 u
->endfile
= AT_ENDFILE
;
708 u
->filename
= strdup (stdout_name
);
715 if (options
.stderr_unit
>= 0)
717 u
= insert_unit (options
.stderr_unit
);
718 u
->s
= error_stream ();
720 u
->flags
.action
= ACTION_WRITE
;
722 u
->flags
.access
= ACCESS_SEQUENTIAL
;
723 u
->flags
.form
= FORM_FORMATTED
;
724 u
->flags
.status
= STATUS_OLD
;
725 u
->flags
.blank
= BLANK_NULL
;
726 u
->flags
.position
= POSITION_ASIS
;
727 u
->flags
.sign
= SIGN_PROCDEFINED
;
728 u
->flags
.decimal
= DECIMAL_POINT
;
729 u
->flags
.encoding
= ENCODING_DEFAULT
;
730 u
->flags
.async
= ASYNC_NO
;
731 u
->flags
.round
= ROUND_PROCDEFINED
;
732 u
->flags
.share
= SHARE_UNSPECIFIED
;
733 u
->flags
.cc
= CC_LIST
;
735 u
->recl
= default_recl
;
736 u
->endfile
= AT_ENDFILE
;
738 u
->filename
= strdup (stderr_name
);
740 fbuf_init (u
, 256); /* 256 bytes should be enough, probably not doing
741 any kind of exotic formatting to stderr. */
745 /* The default internal units. */
746 u
= insert_unit (GFC_INTERNAL_UNIT
);
748 u
= insert_unit (GFC_INTERNAL_UNIT4
);
754 close_unit_1 (gfc_unit
*u
, int locked
)
758 if (ASYNC_IO
&& u
->au
)
761 /* If there are previously written bytes from a write with ADVANCE="no"
762 Reposition the buffer before closing. */
763 if (u
->previous_nonadvancing_write
)
764 finish_last_advance_record (u
);
766 rc
= (u
->s
== NULL
) ? 0 : sclose (u
->s
) == -1;
770 WRLOCK (&unit_rwlock
);
772 for (i
= 0; i
< CACHE_SIZE
; i
++)
773 if (unit_cache
[i
] == u
)
774 unit_cache
[i
] = NULL
;
781 free_format_hash_table (u
);
784 if (u
->unit_number
<= NEWUNIT_START
)
785 newunit_free (u
->unit_number
);
790 /* If there are any threads waiting in find_unit for this unit,
791 avoid freeing the memory, the last such thread will free it
794 destroy_unit_mutex (u
);
797 RWUNLOCK (&unit_rwlock
);
803 unlock_unit (gfc_unit
*u
)
807 NOTE ("unlock_unit = %d", u
->unit_number
);
809 NOTE ("unlock_unit done");
813 /* close_unit()-- Close a unit. The stream is closed, and any memory
814 associated with the stream is freed. Returns nonzero on I/O error.
815 Should be called with the u->lock locked. */
818 close_unit (gfc_unit
*u
)
820 return close_unit_1 (u
, 0);
824 /* close_units()-- Delete units on completion. We just keep deleting
825 the root of the treap until there is nothing left.
826 Not sure what to do with locking here. Some other thread might be
827 holding some unit's lock and perhaps hold it indefinitely
828 (e.g. waiting for input from some pipe) and close_units shouldn't
829 delay the program too much. */
834 WRLOCK (&unit_rwlock
);
835 while (unit_root
!= NULL
)
836 close_unit_1 (unit_root
, 1);
837 RWUNLOCK (&unit_rwlock
);
841 #ifdef HAVE_POSIX_2008_LOCALE
842 freelocale (c_locale
);
847 /* High level interface to truncate a file, i.e. flush format buffers,
848 and generate an error or set some flags. Just like POSIX
849 ftruncate, returns 0 on success, -1 on failure. */
852 unit_truncate (gfc_unit
*u
, gfc_offset pos
, st_parameter_common
*common
)
856 /* Make sure format buffer is flushed. */
857 if (u
->flags
.form
== FORM_FORMATTED
)
859 if (u
->mode
== READING
)
860 pos
+= fbuf_reset (u
);
862 fbuf_flush (u
, u
->mode
);
865 /* struncate() should flush the stream buffer if necessary, so don't
866 bother calling sflush() here. */
867 ret
= struncate (u
->s
, pos
);
870 generate_error (common
, LIBERROR_OS
, NULL
);
873 u
->endfile
= AT_ENDFILE
;
874 u
->flags
.position
= POSITION_APPEND
;
881 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
882 name of the associated file, otherwise return the empty string. The caller
883 must free memory allocated for the filename string. */
886 filename_from_unit (int n
)
895 c
= compare (n
, u
->unit_number
);
904 /* Get the filename. */
905 if (u
!= NULL
&& u
->filename
!= NULL
)
906 return strdup (u
->filename
);
908 return (char *) NULL
;
912 finish_last_advance_record (gfc_unit
*u
)
915 if (u
->saved_pos
> 0)
916 fbuf_seek (u
, u
->saved_pos
, SEEK_CUR
);
918 if (!(u
->unit_number
== options
.stdout_unit
919 || u
->unit_number
== options
.stderr_unit
))
926 char *p
= fbuf_alloc (u
, len
);
928 os_error ("Completing record after ADVANCE_NO failed");
935 fbuf_flush (u
, u
->mode
);
939 /* Assign a negative number for NEWUNIT in OPEN statements or for
944 WRLOCK (&unit_rwlock
);
947 newunits
= xcalloc (16, 1);
951 /* Search for the next available newunit. */
952 for (int ii
= newunit_lwi
; ii
< newunit_size
; ii
++)
957 newunit_lwi
= ii
+ 1;
958 RWUNLOCK (&unit_rwlock
);
959 return -ii
+ NEWUNIT_START
;
963 /* Search failed, bump size of array and allocate the first
965 int old_size
= newunit_size
;
967 newunits
= xrealloc (newunits
, newunit_size
);
968 memset (newunits
+ old_size
, 0, old_size
);
969 newunits
[old_size
] = true;
970 newunit_lwi
= old_size
+ 1;
971 RWUNLOCK (&unit_rwlock
);
972 return -old_size
+ NEWUNIT_START
;
976 /* Free a previously allocated newunit= unit number. unit_rwlock must
977 be held when calling. */
980 newunit_free (int unit
)
982 int ind
= -unit
+ NEWUNIT_START
;
983 assert(ind
>= 0 && ind
< newunit_size
);
984 newunits
[ind
] = false;
985 if (ind
< newunit_lwi
)