1 /* Copyright (C) 2002-2017 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/>. */
35 UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
36 Concurrent use of different units should be supported, so
37 each unit has its own lock, LOCK.
38 Open should be atomic with its reopening of units and list_read.c
39 in several places needs find_unit another unit while holding stdin
40 unit's lock, so it must be possible to acquire UNIT_LOCK while holding
41 some unit's lock. Therefore to avoid deadlocks, it is forbidden
42 to acquire unit's private locks while holding UNIT_LOCK, except
43 for freshly created units (where no other thread can get at their
44 address yet) or when using just trylock rather than lock operation.
45 In addition to unit's private lock each unit has a WAITERS counter
46 and CLOSED flag. WAITERS counter must be either only
47 atomically incremented/decremented in all places (if atomic builtins
48 are supported), or protected by UNIT_LOCK in all places (otherwise).
49 CLOSED flag must be always protected by unit's LOCK.
50 After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
51 WAITERS must be incremented to avoid concurrent close from freeing
52 the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
53 Unit freeing is always done under UNIT_LOCK. If close_unit sees any
54 WAITERS, it doesn't free the unit but instead sets the CLOSED flag
55 and the thread that decrements WAITERS to zero while CLOSED flag is
56 set is responsible for freeing it (while holding UNIT_LOCK).
57 flush_all_units operation is iterating over the unit tree with
58 increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
59 flush each unit (and therefore needs the unit's LOCK held as well).
60 To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
61 remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
62 unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
63 the smallest UNIT_NUMBER above the last one flushed.
65 If find_unit/find_or_create_unit/find_file/get_unit routines return
66 non-NULL, the returned unit has its private lock locked and when the
67 caller is done with it, it must call either unlock_unit or close_unit
68 on it. unlock_unit or close_unit must be always called only with the
73 /* Table of allocated newunit values. A simple solution would be to
74 map OS file descriptors (fd's) to unit numbers, e.g. with newunit =
75 -fd - 2, however that doesn't work since Fortran allows an existing
76 unit number to be reassociated with a new file. Thus the simple
77 approach may lead to a situation where we'd try to assign a
78 (negative) unit number which already exists. Hence we must keep
79 track of allocated newunit values ourselves. This is the purpose of
80 the newunits array. The indices map to newunit values as newunit =
81 -index + NEWUNIT_FIRST. E.g. newunits[0] having the value true
82 means that a unit with number NEWUNIT_FIRST exists. Similar to
83 POSIX file descriptors, we always allocate the lowest (in absolute
84 value) available unit number.
86 static bool *newunits
;
87 static int newunit_size
; /* Total number of elements in the newunits array. */
88 /* Low water indicator for the newunits array. Below the LWI all the
89 units are allocated, above and equal to the LWI there may be both
90 allocated and free units. */
91 static int newunit_lwi
;
92 static void newunit_free (int);
94 /* Unit numbers assigned with NEWUNIT start from here. */
95 #define NEWUNIT_START -10
98 #define NEWUNIT_STACK_SIZE 16
100 /* A stack to save previously used newunit-assigned unit numbers to
101 allow them to be reused without reallocating the gfc_unit structure
102 which is still in the treap. */
103 static gfc_saved_unit newunit_stack
[NEWUNIT_STACK_SIZE
];
104 static int newunit_tos
= 0; /* Index to Top of Stack. */
108 static gfc_unit
*unit_cache
[CACHE_SIZE
];
109 gfc_offset max_offset
;
111 #ifdef __GTHREAD_MUTEX_INIT
112 __gthread_mutex_t unit_lock
= __GTHREAD_MUTEX_INIT
;
114 __gthread_mutex_t unit_lock
;
117 /* We use these filenames for error reporting. */
119 static char stdin_name
[] = "stdin";
120 static char stdout_name
[] = "stdout";
121 static char stderr_name
[] = "stderr";
124 #ifdef HAVE_NEWLOCALE
127 /* If we don't have POSIX 2008 per-thread locales, we need to use the
128 traditional setlocale(). To prevent multiple concurrent threads
129 doing formatted I/O from messing up the locale, we need to store a
130 global old_locale, and a counter keeping track of how many threads
131 are currently doing formatted I/O. The first thread saves the old
132 locale, and the last one restores it. */
135 #ifdef __GTHREAD_MUTEX_INIT
136 __gthread_mutex_t old_locale_lock
= __GTHREAD_MUTEX_INIT
;
138 __gthread_mutex_t old_locale_lock
;
143 /* This implementation is based on Stefan Nilsson's article in the
144 * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
146 /* pseudo_random()-- Simple linear congruential pseudorandom number
147 * generator. The period of this generator is 44071, which is plenty
148 * for our purposes. */
153 static int x0
= 5341;
155 x0
= (22611 * x0
+ 10) % 44071;
160 /* rotate_left()-- Rotate the treap left */
163 rotate_left (gfc_unit
* t
)
168 t
->right
= t
->right
->left
;
175 /* rotate_right()-- Rotate the treap right */
178 rotate_right (gfc_unit
* t
)
183 t
->left
= t
->left
->right
;
191 compare (int a
, int b
)
202 /* insert()-- Recursive insertion function. Returns the updated treap. */
205 insert (gfc_unit
*new, gfc_unit
*t
)
212 c
= compare (new->unit_number
, t
->unit_number
);
216 t
->left
= insert (new, t
->left
);
217 if (t
->priority
< t
->left
->priority
)
218 t
= rotate_right (t
);
223 t
->right
= insert (new, t
->right
);
224 if (t
->priority
< t
->right
->priority
)
229 internal_error (NULL
, "insert(): Duplicate key found!");
235 /* insert_unit()-- Create a new node, insert it into the treap. */
240 gfc_unit
*u
= xcalloc (1, sizeof (gfc_unit
));
242 #ifdef __GTHREAD_MUTEX_INIT
244 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
248 __GTHREAD_MUTEX_INIT_FUNCTION (&u
->lock
);
250 __gthread_mutex_lock (&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
);
327 /* get_gfc_unit()-- Given an integer, return a pointer to the unit
328 * structure. Returns NULL if the unit does not exist,
329 * otherwise returns a locked unit. */
332 get_gfc_unit (int n
, int do_create
)
337 __gthread_mutex_lock (&unit_lock
);
339 for (c
= 0; c
< CACHE_SIZE
; c
++)
340 if (unit_cache
[c
] != NULL
&& unit_cache
[c
]->unit_number
== n
)
349 c
= compare (n
, p
->unit_number
);
358 if (p
== NULL
&& do_create
)
366 for (c
= 0; c
< CACHE_SIZE
- 1; c
++)
367 unit_cache
[c
] = unit_cache
[c
+ 1];
369 unit_cache
[CACHE_SIZE
- 1] = p
;
374 /* Newly created units have their lock held already
375 from insert_unit. Just unlock UNIT_LOCK and return. */
376 __gthread_mutex_unlock (&unit_lock
);
381 if (p
!= NULL
&& (p
->child_dtio
== 0))
384 if (! __gthread_mutex_trylock (&p
->lock
))
386 /* assert (p->closed == 0); */
387 __gthread_mutex_unlock (&unit_lock
);
391 inc_waiting_locked (p
);
395 __gthread_mutex_unlock (&unit_lock
);
397 if (p
!= NULL
&& (p
->child_dtio
== 0))
399 __gthread_mutex_lock (&p
->lock
);
402 __gthread_mutex_lock (&unit_lock
);
403 __gthread_mutex_unlock (&p
->lock
);
404 if (predec_waiting_locked (p
) == 0)
405 destroy_unit_mutex (p
);
409 dec_waiting_unlocked (p
);
418 return get_gfc_unit (n
, 0);
423 find_or_create_unit (int n
)
425 return get_gfc_unit (n
, 1);
429 /* Helper function to check rank, stride, format string, and namelist.
430 This is used for optimization. You can't trim out blanks or shorten
431 the string if trailing spaces are significant. */
433 is_trim_ok (st_parameter_dt
*dtp
)
435 /* Check rank and stride. */
436 if (dtp
->internal_unit_desc
)
438 /* Format strings can not have 'BZ' or '/'. */
439 if (dtp
->common
.flags
& IOPARM_DT_HAS_FORMAT
)
441 char *p
= dtp
->format
;
442 if (dtp
->common
.flags
& IOPARM_DT_HAS_BLANK
)
444 for (gfc_charlen_type i
= 0; i
< dtp
->format_len
; i
++)
446 if (p
[i
] == '/') return false;
447 if (p
[i
] == 'b' || p
[i
] == 'B')
448 if (p
[i
+1] == 'z' || p
[i
+1] == 'Z')
452 if (dtp
->u
.p
.ionml
) /* A namelist. */
459 set_internal_unit (st_parameter_dt
*dtp
, gfc_unit
*iunit
, int kind
)
461 gfc_offset start_record
= 0;
463 iunit
->recl
= dtp
->internal_unit_len
;
464 iunit
->internal_unit
= dtp
->internal_unit
;
465 iunit
->internal_unit_len
= dtp
->internal_unit_len
;
466 iunit
->internal_unit_kind
= kind
;
468 /* As an optimization, adjust the unit record length to not
469 include trailing blanks. This will not work under certain conditions
470 where trailing blanks have significance. */
471 if (dtp
->u
.p
.mode
== READING
&& is_trim_ok (dtp
))
475 len
= string_len_trim (iunit
->internal_unit_len
,
476 iunit
->internal_unit
);
478 len
= string_len_trim_char4 (iunit
->internal_unit_len
,
479 (const gfc_char4_t
*) iunit
->internal_unit
);
480 iunit
->internal_unit_len
= len
;
481 iunit
->recl
= iunit
->internal_unit_len
;
484 /* Set up the looping specification from the array descriptor, if any. */
486 if (is_array_io (dtp
))
488 iunit
->rank
= GFC_DESCRIPTOR_RANK (dtp
->internal_unit_desc
);
489 iunit
->ls
= (array_loop_spec
*)
490 xmallocarray (iunit
->rank
, sizeof (array_loop_spec
));
491 iunit
->internal_unit_len
*=
492 init_loop_spec (dtp
->internal_unit_desc
, iunit
->ls
, &start_record
);
494 start_record
*= iunit
->recl
;
497 /* Set initial values for unit parameters. */
499 iunit
->s
= open_internal4 (iunit
->internal_unit
- start_record
,
500 iunit
->internal_unit_len
, -start_record
);
502 iunit
->s
= open_internal (iunit
->internal_unit
- start_record
,
503 iunit
->internal_unit_len
, -start_record
);
505 iunit
->bytes_left
= iunit
->recl
;
506 iunit
->last_record
=0;
508 iunit
->current_record
=0;
510 iunit
->endfile
= NO_ENDFILE
;
512 /* Set flags for the internal unit. */
514 iunit
->flags
.access
= ACCESS_SEQUENTIAL
;
515 iunit
->flags
.action
= ACTION_READWRITE
;
516 iunit
->flags
.blank
= BLANK_NULL
;
517 iunit
->flags
.form
= FORM_FORMATTED
;
518 iunit
->flags
.pad
= PAD_YES
;
519 iunit
->flags
.status
= STATUS_UNSPECIFIED
;
520 iunit
->flags
.sign
= SIGN_UNSPECIFIED
;
521 iunit
->flags
.decimal
= DECIMAL_POINT
;
522 iunit
->flags
.delim
= DELIM_UNSPECIFIED
;
523 iunit
->flags
.encoding
= ENCODING_DEFAULT
;
524 iunit
->flags
.async
= ASYNC_NO
;
525 iunit
->flags
.round
= ROUND_UNSPECIFIED
;
527 /* Initialize the data transfer parameters. */
529 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
530 dtp
->u
.p
.seen_dollar
= 0;
532 dtp
->u
.p
.pending_spaces
= 0;
533 dtp
->u
.p
.max_pos
= 0;
539 /* stash_internal_unit()-- Push the internal unit number onto the
542 stash_internal_unit (st_parameter_dt
*dtp
)
544 __gthread_mutex_lock (&unit_lock
);
546 if (newunit_tos
>= NEWUNIT_STACK_SIZE
)
547 internal_error (&dtp
->common
, "stash_internal_unit(): Stack Size Exceeded");
548 newunit_stack
[newunit_tos
].unit_number
= dtp
->common
.unit
;
549 newunit_stack
[newunit_tos
].unit
= dtp
->u
.p
.current_unit
;
550 __gthread_mutex_unlock (&unit_lock
);
555 /* get_unit()-- Returns the unit structure associated with the integer
556 unit or the internal file. */
559 get_unit (st_parameter_dt
*dtp
, int do_create
)
563 if ((dtp
->common
.flags
& IOPARM_DT_HAS_INTERNAL_UNIT
) != 0)
566 if (dtp
->common
.unit
== GFC_INTERNAL_UNIT
)
568 else if (dtp
->common
.unit
== GFC_INTERNAL_UNIT4
)
571 internal_error (&dtp
->common
, "get_unit(): Bad internal unit KIND");
573 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) != 0)
575 dtp
->u
.p
.unit_is_internal
= 1;
576 dtp
->common
.unit
= newunit_alloc ();
577 unit
= get_gfc_unit (dtp
->common
.unit
, do_create
);
578 set_internal_unit (dtp
, unit
, kind
);
579 fbuf_init (unit
, 128);
586 dtp
->common
.unit
= newunit_stack
[newunit_tos
].unit_number
;
587 unit
= newunit_stack
[newunit_tos
--].unit
;
588 unit
->fbuf
->act
= unit
->fbuf
->pos
= 0;
592 dtp
->common
.unit
= newunit_alloc ();
593 unit
= xcalloc (1, sizeof (gfc_unit
));
594 fbuf_init (unit
, 128);
596 set_internal_unit (dtp
, unit
, kind
);
600 /* Has to be an external unit. */
601 dtp
->u
.p
.unit_is_internal
= 0;
602 dtp
->internal_unit
= NULL
;
603 dtp
->internal_unit_desc
= NULL
;
604 /* For an external unit with unit number < 0 creating it on the fly
605 is not allowed, such units must be created with
606 OPEN(NEWUNIT=...). */
607 if (dtp
->common
.unit
< 0)
608 return get_gfc_unit (dtp
->common
.unit
, 0);
609 return get_gfc_unit (dtp
->common
.unit
, do_create
);
613 /*************************/
614 /* Initialize everything. */
622 #ifdef HAVE_NEWLOCALE
623 c_locale
= newlocale (0, "C", 0);
625 #ifndef __GTHREAD_MUTEX_INIT
626 __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock
);
630 #ifndef __GTHREAD_MUTEX_INIT
631 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock
);
634 if (options
.stdin_unit
>= 0)
636 u
= insert_unit (options
.stdin_unit
);
637 u
->s
= input_stream ();
639 u
->flags
.action
= ACTION_READ
;
641 u
->flags
.access
= ACCESS_SEQUENTIAL
;
642 u
->flags
.form
= FORM_FORMATTED
;
643 u
->flags
.status
= STATUS_OLD
;
644 u
->flags
.blank
= BLANK_NULL
;
645 u
->flags
.pad
= PAD_YES
;
646 u
->flags
.position
= POSITION_ASIS
;
647 u
->flags
.sign
= SIGN_UNSPECIFIED
;
648 u
->flags
.decimal
= DECIMAL_POINT
;
649 u
->flags
.delim
= DELIM_UNSPECIFIED
;
650 u
->flags
.encoding
= ENCODING_DEFAULT
;
651 u
->flags
.async
= ASYNC_NO
;
652 u
->flags
.round
= ROUND_UNSPECIFIED
;
653 u
->flags
.share
= SHARE_UNSPECIFIED
;
654 u
->flags
.cc
= CC_LIST
;
656 u
->recl
= options
.default_recl
;
657 u
->endfile
= NO_ENDFILE
;
659 u
->filename
= strdup (stdin_name
);
663 __gthread_mutex_unlock (&u
->lock
);
666 if (options
.stdout_unit
>= 0)
668 u
= insert_unit (options
.stdout_unit
);
669 u
->s
= output_stream ();
671 u
->flags
.action
= ACTION_WRITE
;
673 u
->flags
.access
= ACCESS_SEQUENTIAL
;
674 u
->flags
.form
= FORM_FORMATTED
;
675 u
->flags
.status
= STATUS_OLD
;
676 u
->flags
.blank
= BLANK_NULL
;
677 u
->flags
.position
= POSITION_ASIS
;
678 u
->flags
.sign
= SIGN_UNSPECIFIED
;
679 u
->flags
.decimal
= DECIMAL_POINT
;
680 u
->flags
.delim
= DELIM_UNSPECIFIED
;
681 u
->flags
.encoding
= ENCODING_DEFAULT
;
682 u
->flags
.async
= ASYNC_NO
;
683 u
->flags
.round
= ROUND_UNSPECIFIED
;
684 u
->flags
.share
= SHARE_UNSPECIFIED
;
685 u
->flags
.cc
= CC_LIST
;
687 u
->recl
= options
.default_recl
;
688 u
->endfile
= AT_ENDFILE
;
690 u
->filename
= strdup (stdout_name
);
694 __gthread_mutex_unlock (&u
->lock
);
697 if (options
.stderr_unit
>= 0)
699 u
= insert_unit (options
.stderr_unit
);
700 u
->s
= error_stream ();
702 u
->flags
.action
= ACTION_WRITE
;
704 u
->flags
.access
= ACCESS_SEQUENTIAL
;
705 u
->flags
.form
= FORM_FORMATTED
;
706 u
->flags
.status
= STATUS_OLD
;
707 u
->flags
.blank
= BLANK_NULL
;
708 u
->flags
.position
= POSITION_ASIS
;
709 u
->flags
.sign
= SIGN_UNSPECIFIED
;
710 u
->flags
.decimal
= DECIMAL_POINT
;
711 u
->flags
.encoding
= ENCODING_DEFAULT
;
712 u
->flags
.async
= ASYNC_NO
;
713 u
->flags
.round
= ROUND_UNSPECIFIED
;
714 u
->flags
.share
= SHARE_UNSPECIFIED
;
715 u
->flags
.cc
= CC_LIST
;
717 u
->recl
= options
.default_recl
;
718 u
->endfile
= AT_ENDFILE
;
720 u
->filename
= strdup (stderr_name
);
722 fbuf_init (u
, 256); /* 256 bytes should be enough, probably not doing
723 any kind of exotic formatting to stderr. */
725 __gthread_mutex_unlock (&u
->lock
);
728 /* Calculate the maximum file offset in a portable manner.
729 max will be the largest signed number for the type gfc_offset.
730 set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
732 for (i
= 0; i
< sizeof (max_offset
) * 8 - 1; i
++)
733 max_offset
= max_offset
+ ((gfc_offset
) 1 << i
);
735 /* Initialize the newunit stack. */
736 memset (newunit_stack
, 0, NEWUNIT_STACK_SIZE
* sizeof(gfc_saved_unit
));
742 close_unit_1 (gfc_unit
*u
, int locked
)
746 /* If there are previously written bytes from a write with ADVANCE="no"
747 Reposition the buffer before closing. */
748 if (u
->previous_nonadvancing_write
)
749 finish_last_advance_record (u
);
751 rc
= (u
->s
== NULL
) ? 0 : sclose (u
->s
) == -1;
755 __gthread_mutex_lock (&unit_lock
);
757 for (i
= 0; i
< CACHE_SIZE
; i
++)
758 if (unit_cache
[i
] == u
)
759 unit_cache
[i
] = NULL
;
766 free_format_hash_table (u
);
769 if (u
->unit_number
<= NEWUNIT_START
)
770 newunit_free (u
->unit_number
);
773 __gthread_mutex_unlock (&u
->lock
);
775 /* If there are any threads waiting in find_unit for this unit,
776 avoid freeing the memory, the last such thread will free it
779 destroy_unit_mutex (u
);
782 __gthread_mutex_unlock (&unit_lock
);
788 unlock_unit (gfc_unit
*u
)
790 __gthread_mutex_unlock (&u
->lock
);
793 /* close_unit()-- Close a unit. The stream is closed, and any memory
794 associated with the stream is freed. Returns nonzero on I/O error.
795 Should be called with the u->lock locked. */
798 close_unit (gfc_unit
*u
)
800 return close_unit_1 (u
, 0);
804 /* close_units()-- Delete units on completion. We just keep deleting
805 the root of the treap until there is nothing left.
806 Not sure what to do with locking here. Some other thread might be
807 holding some unit's lock and perhaps hold it indefinitely
808 (e.g. waiting for input from some pipe) and close_units shouldn't
809 delay the program too much. */
814 __gthread_mutex_lock (&unit_lock
);
815 while (unit_root
!= NULL
)
816 close_unit_1 (unit_root
, 1);
817 __gthread_mutex_unlock (&unit_lock
);
819 while (newunit_tos
!= 0)
820 if (newunit_stack
[newunit_tos
].unit
)
822 fbuf_destroy (newunit_stack
[newunit_tos
].unit
);
823 free (newunit_stack
[newunit_tos
].unit
->s
);
824 free (newunit_stack
[newunit_tos
--].unit
);
829 #ifdef HAVE_FREELOCALE
830 freelocale (c_locale
);
835 /* High level interface to truncate a file, i.e. flush format buffers,
836 and generate an error or set some flags. Just like POSIX
837 ftruncate, returns 0 on success, -1 on failure. */
840 unit_truncate (gfc_unit
* u
, gfc_offset pos
, st_parameter_common
* common
)
844 /* Make sure format buffer is flushed. */
845 if (u
->flags
.form
== FORM_FORMATTED
)
847 if (u
->mode
== READING
)
848 pos
+= fbuf_reset (u
);
850 fbuf_flush (u
, u
->mode
);
853 /* struncate() should flush the stream buffer if necessary, so don't
854 bother calling sflush() here. */
855 ret
= struncate (u
->s
, pos
);
858 generate_error (common
, LIBERROR_OS
, NULL
);
861 u
->endfile
= AT_ENDFILE
;
862 u
->flags
.position
= POSITION_APPEND
;
869 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
870 name of the associated file, otherwise return the empty string. The caller
871 must free memory allocated for the filename string. */
874 filename_from_unit (int n
)
883 c
= compare (n
, u
->unit_number
);
892 /* Get the filename. */
893 if (u
!= NULL
&& u
->filename
!= NULL
)
894 return strdup (u
->filename
);
896 return (char *) NULL
;
900 finish_last_advance_record (gfc_unit
*u
)
903 if (u
->saved_pos
> 0)
904 fbuf_seek (u
, u
->saved_pos
, SEEK_CUR
);
906 if (!(u
->unit_number
== options
.stdout_unit
907 || u
->unit_number
== options
.stderr_unit
))
914 char *p
= fbuf_alloc (u
, len
);
916 os_error ("Completing record after ADVANCE_NO failed");
923 fbuf_flush (u
, u
->mode
);
927 /* Assign a negative number for NEWUNIT in OPEN statements or for
932 __gthread_mutex_lock (&unit_lock
);
935 newunits
= xcalloc (16, 1);
939 /* Search for the next available newunit. */
940 for (int ii
= newunit_lwi
; ii
< newunit_size
; ii
++)
945 newunit_lwi
= ii
+ 1;
946 __gthread_mutex_unlock (&unit_lock
);
947 return -ii
+ NEWUNIT_START
;
951 /* Search failed, bump size of array and allocate the first
953 int old_size
= newunit_size
;
955 newunits
= xrealloc (newunits
, newunit_size
);
956 memset (newunits
+ old_size
, 0, old_size
);
957 newunits
[old_size
] = true;
958 newunit_lwi
= old_size
+ 1;
959 __gthread_mutex_unlock (&unit_lock
);
960 return -old_size
+ NEWUNIT_START
;
964 /* Free a previously allocated newunit= unit number. unit_lock must
965 be held when calling. */
968 newunit_free (int unit
)
970 int ind
= -unit
+ NEWUNIT_START
;
971 assert(ind
>= 0 && ind
< newunit_size
);
972 newunits
[ind
] = false;
973 if (ind
< newunit_lwi
)