]>
Commit | Line | Data |
---|---|---|
cbe34bb5 | 1 | /* Copyright (C) 2002-2017 Free Software Foundation, Inc. |
6de9cd9a | 2 | Contributed by Andy Vaught |
10256cbe | 3 | F2003 I/O support contributed by Jerry DeLisle |
6de9cd9a | 4 | |
bb408e87 | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a DN |
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 | |
748086b7 | 9 | the Free Software Foundation; either version 3, or (at your option) |
6de9cd9a DN |
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 | ||
748086b7 JJ |
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/>. */ | |
6de9cd9a | 25 | |
36ae8a61 | 26 | #include "io.h" |
92cbdb68 JB |
27 | #include "fbuf.h" |
28 | #include "format.h" | |
29 | #include "unix.h" | |
6de9cd9a | 30 | #include <string.h> |
c04d4ede | 31 | #include <assert.h> |
6de9cd9a DN |
32 | |
33 | ||
5e805e44 JJ |
34 | /* IO locking rules: |
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. | |
64 | ||
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 | |
69 | private lock held. */ | |
70 | ||
6de9cd9a | 71 | |
c04d4ede JB |
72 | |
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. | |
85 | */ | |
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); | |
93 | ||
94 | /* Unit numbers assigned with NEWUNIT start from here. */ | |
95 | #define NEWUNIT_START -10 | |
96 | ||
97 | ||
4a8d4422 | 98 | #define NEWUNIT_STACK_SIZE 16 |
6de9cd9a | 99 | |
4a8d4422 JD |
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. */ | |
105 | ||
c04d4ede | 106 | |
6de9cd9a | 107 | #define CACHE_SIZE 3 |
6f34d6e0 | 108 | static gfc_unit *unit_cache[CACHE_SIZE]; |
5e805e44 JJ |
109 | gfc_offset max_offset; |
110 | gfc_unit *unit_root; | |
111 | #ifdef __GTHREAD_MUTEX_INIT | |
112 | __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT; | |
113 | #else | |
114 | __gthread_mutex_t unit_lock; | |
115 | #endif | |
6de9cd9a | 116 | |
87557722 JD |
117 | /* We use these filenames for error reporting. */ |
118 | ||
119 | static char stdin_name[] = "stdin"; | |
120 | static char stdout_name[] = "stdout"; | |
121 | static char stderr_name[] = "stderr"; | |
122 | ||
9cbecd06 JB |
123 | |
124 | #ifdef HAVE_NEWLOCALE | |
125 | locale_t c_locale; | |
126 | #else | |
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. */ | |
133 | char *old_locale; | |
134 | int old_locale_ctr; | |
135 | #ifdef __GTHREAD_MUTEX_INIT | |
136 | __gthread_mutex_t old_locale_lock = __GTHREAD_MUTEX_INIT; | |
137 | #else | |
138 | __gthread_mutex_t old_locale_lock; | |
139 | #endif | |
140 | #endif | |
141 | ||
142 | ||
6de9cd9a | 143 | /* This implementation is based on Stefan Nilsson's article in the |
f29876bb | 144 | July 1997 Doctor Dobb's Journal, "Treaps in Java". */ |
6de9cd9a DN |
145 | |
146 | /* pseudo_random()-- Simple linear congruential pseudorandom number | |
f29876bb JD |
147 | generator. The period of this generator is 44071, which is plenty |
148 | for our purposes. */ | |
6de9cd9a DN |
149 | |
150 | static int | |
151 | pseudo_random (void) | |
152 | { | |
153 | static int x0 = 5341; | |
154 | ||
155 | x0 = (22611 * x0 + 10) % 44071; | |
156 | return x0; | |
157 | } | |
158 | ||
159 | ||
160 | /* rotate_left()-- Rotate the treap left */ | |
161 | ||
909087e0 | 162 | static gfc_unit * |
f29876bb | 163 | rotate_left (gfc_unit *t) |
6de9cd9a | 164 | { |
909087e0 | 165 | gfc_unit *temp; |
6de9cd9a DN |
166 | |
167 | temp = t->right; | |
168 | t->right = t->right->left; | |
169 | temp->left = t; | |
170 | ||
171 | return temp; | |
172 | } | |
173 | ||
174 | ||
175 | /* rotate_right()-- Rotate the treap right */ | |
176 | ||
909087e0 | 177 | static gfc_unit * |
f29876bb | 178 | rotate_right (gfc_unit *t) |
6de9cd9a | 179 | { |
909087e0 | 180 | gfc_unit *temp; |
6de9cd9a DN |
181 | |
182 | temp = t->left; | |
183 | t->left = t->left->right; | |
184 | temp->right = t; | |
185 | ||
186 | return temp; | |
187 | } | |
188 | ||
189 | ||
6de9cd9a DN |
190 | static int |
191 | compare (int a, int b) | |
192 | { | |
6de9cd9a DN |
193 | if (a < b) |
194 | return -1; | |
195 | if (a > b) | |
196 | return 1; | |
197 | ||
198 | return 0; | |
199 | } | |
200 | ||
201 | ||
202 | /* insert()-- Recursive insertion function. Returns the updated treap. */ | |
203 | ||
909087e0 | 204 | static gfc_unit * |
5e805e44 | 205 | insert (gfc_unit *new, gfc_unit *t) |
6de9cd9a DN |
206 | { |
207 | int c; | |
208 | ||
209 | if (t == NULL) | |
210 | return new; | |
211 | ||
212 | c = compare (new->unit_number, t->unit_number); | |
213 | ||
214 | if (c < 0) | |
215 | { | |
216 | t->left = insert (new, t->left); | |
217 | if (t->priority < t->left->priority) | |
218 | t = rotate_right (t); | |
219 | } | |
220 | ||
221 | if (c > 0) | |
222 | { | |
223 | t->right = insert (new, t->right); | |
224 | if (t->priority < t->right->priority) | |
225 | t = rotate_left (t); | |
226 | } | |
227 | ||
228 | if (c == 0) | |
5e805e44 | 229 | internal_error (NULL, "insert(): Duplicate key found!"); |
6de9cd9a DN |
230 | |
231 | return t; | |
232 | } | |
233 | ||
234 | ||
5e805e44 | 235 | /* insert_unit()-- Create a new node, insert it into the treap. */ |
6de9cd9a | 236 | |
5e805e44 JJ |
237 | static gfc_unit * |
238 | insert_unit (int n) | |
6de9cd9a | 239 | { |
f4471acb | 240 | gfc_unit *u = xcalloc (1, sizeof (gfc_unit)); |
5e805e44 JJ |
241 | u->unit_number = n; |
242 | #ifdef __GTHREAD_MUTEX_INIT | |
243 | { | |
244 | __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT; | |
245 | u->lock = tmp; | |
246 | } | |
247 | #else | |
248 | __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock); | |
249 | #endif | |
250 | __gthread_mutex_lock (&u->lock); | |
251 | u->priority = pseudo_random (); | |
252 | unit_root = insert (u, unit_root); | |
253 | return u; | |
6de9cd9a DN |
254 | } |
255 | ||
256 | ||
ef4195d6 JD |
257 | /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */ |
258 | ||
259 | static void | |
f29876bb | 260 | destroy_unit_mutex (gfc_unit *u) |
ef4195d6 | 261 | { |
4dabf736 | 262 | __gthread_mutex_destroy (&u->lock); |
bb408e87 | 263 | free (u); |
ef4195d6 JD |
264 | } |
265 | ||
266 | ||
909087e0 | 267 | static gfc_unit * |
f29876bb | 268 | delete_root (gfc_unit *t) |
6de9cd9a | 269 | { |
909087e0 | 270 | gfc_unit *temp; |
6de9cd9a DN |
271 | |
272 | if (t->left == NULL) | |
273 | return t->right; | |
274 | if (t->right == NULL) | |
275 | return t->left; | |
276 | ||
277 | if (t->left->priority > t->right->priority) | |
278 | { | |
279 | temp = rotate_right (t); | |
280 | temp->right = delete_root (t); | |
281 | } | |
282 | else | |
283 | { | |
284 | temp = rotate_left (t); | |
285 | temp->left = delete_root (t); | |
286 | } | |
287 | ||
288 | return temp; | |
289 | } | |
290 | ||
291 | ||
292 | /* delete_treap()-- Delete an element from a tree. The 'old' value | |
f29876bb JD |
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. */ | |
6de9cd9a | 296 | |
909087e0 | 297 | static gfc_unit * |
f29876bb | 298 | delete_treap (gfc_unit *old, gfc_unit *t) |
6de9cd9a DN |
299 | { |
300 | int c; | |
301 | ||
302 | if (t == NULL) | |
303 | return NULL; | |
304 | ||
305 | c = compare (old->unit_number, t->unit_number); | |
306 | ||
307 | if (c < 0) | |
308 | t->left = delete_treap (old, t->left); | |
309 | if (c > 0) | |
310 | t->right = delete_treap (old, t->right); | |
311 | if (c == 0) | |
312 | t = delete_root (t); | |
313 | ||
314 | return t; | |
315 | } | |
316 | ||
317 | ||
318 | /* delete_unit()-- Delete a unit from a tree */ | |
319 | ||
320 | static void | |
f29876bb | 321 | delete_unit (gfc_unit *old) |
6de9cd9a | 322 | { |
5e805e44 | 323 | unit_root = delete_treap (old, unit_root); |
6de9cd9a DN |
324 | } |
325 | ||
326 | ||
4a8d4422 | 327 | /* get_gfc_unit()-- Given an integer, return a pointer to the unit |
f29876bb JD |
328 | structure. Returns NULL if the unit does not exist, |
329 | otherwise returns a locked unit. */ | |
6de9cd9a | 330 | |
5e805e44 | 331 | static gfc_unit * |
4a8d4422 | 332 | get_gfc_unit (int n, int do_create) |
6de9cd9a | 333 | { |
909087e0 | 334 | gfc_unit *p; |
5e805e44 | 335 | int c, created = 0; |
6de9cd9a | 336 | |
5e805e44 JJ |
337 | __gthread_mutex_lock (&unit_lock); |
338 | retry: | |
6de9cd9a DN |
339 | for (c = 0; c < CACHE_SIZE; c++) |
340 | if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n) | |
341 | { | |
342 | p = unit_cache[c]; | |
5e805e44 | 343 | goto found; |
6de9cd9a DN |
344 | } |
345 | ||
5e805e44 | 346 | p = unit_root; |
6de9cd9a DN |
347 | while (p != NULL) |
348 | { | |
349 | c = compare (n, p->unit_number); | |
350 | if (c < 0) | |
351 | p = p->left; | |
352 | if (c > 0) | |
353 | p = p->right; | |
354 | if (c == 0) | |
355 | break; | |
356 | } | |
357 | ||
5e805e44 JJ |
358 | if (p == NULL && do_create) |
359 | { | |
360 | p = insert_unit (n); | |
361 | created = 1; | |
362 | } | |
363 | ||
6de9cd9a DN |
364 | if (p != NULL) |
365 | { | |
366 | for (c = 0; c < CACHE_SIZE - 1; c++) | |
367 | unit_cache[c] = unit_cache[c + 1]; | |
368 | ||
369 | unit_cache[CACHE_SIZE - 1] = p; | |
370 | } | |
371 | ||
5e805e44 JJ |
372 | if (created) |
373 | { | |
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); | |
377 | return p; | |
378 | } | |
379 | ||
380 | found: | |
e73d3ca6 | 381 | if (p != NULL && (p->child_dtio == 0)) |
5e805e44 JJ |
382 | { |
383 | /* Fast path. */ | |
384 | if (! __gthread_mutex_trylock (&p->lock)) | |
385 | { | |
386 | /* assert (p->closed == 0); */ | |
387 | __gthread_mutex_unlock (&unit_lock); | |
388 | return p; | |
389 | } | |
390 | ||
391 | inc_waiting_locked (p); | |
392 | } | |
393 | ||
4a8d4422 | 394 | |
5e805e44 JJ |
395 | __gthread_mutex_unlock (&unit_lock); |
396 | ||
e73d3ca6 | 397 | if (p != NULL && (p->child_dtio == 0)) |
5e805e44 JJ |
398 | { |
399 | __gthread_mutex_lock (&p->lock); | |
400 | if (p->closed) | |
401 | { | |
402 | __gthread_mutex_lock (&unit_lock); | |
403 | __gthread_mutex_unlock (&p->lock); | |
404 | if (predec_waiting_locked (p) == 0) | |
ef4195d6 | 405 | destroy_unit_mutex (p); |
5e805e44 JJ |
406 | goto retry; |
407 | } | |
408 | ||
409 | dec_waiting_unlocked (p); | |
410 | } | |
6de9cd9a DN |
411 | return p; |
412 | } | |
413 | ||
6f34d6e0 | 414 | |
5e805e44 JJ |
415 | gfc_unit * |
416 | find_unit (int n) | |
417 | { | |
4a8d4422 | 418 | return get_gfc_unit (n, 0); |
5e805e44 JJ |
419 | } |
420 | ||
6f34d6e0 | 421 | |
5e805e44 JJ |
422 | gfc_unit * |
423 | find_or_create_unit (int n) | |
424 | { | |
4a8d4422 | 425 | return get_gfc_unit (n, 1); |
5e805e44 JJ |
426 | } |
427 | ||
6de9cd9a | 428 | |
3b63b663 JD |
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. */ | |
432 | static bool | |
433 | is_trim_ok (st_parameter_dt *dtp) | |
434 | { | |
435 | /* Check rank and stride. */ | |
861b2d2c | 436 | if (dtp->internal_unit_desc) |
3b63b663 JD |
437 | return false; |
438 | /* Format strings can not have 'BZ' or '/'. */ | |
439 | if (dtp->common.flags & IOPARM_DT_HAS_FORMAT) | |
440 | { | |
441 | char *p = dtp->format; | |
c1e9bbcc | 442 | off_t i; |
3b63b663 JD |
443 | if (dtp->common.flags & IOPARM_DT_HAS_BLANK) |
444 | return false; | |
c1e9bbcc | 445 | for (i = 0; i < dtp->format_len; i++) |
3b63b663 JD |
446 | { |
447 | if (p[i] == '/') return false; | |
448 | if (p[i] == 'b' || p[i] == 'B') | |
449 | if (p[i+1] == 'z' || p[i+1] == 'Z') | |
450 | return false; | |
451 | } | |
452 | } | |
453 | if (dtp->u.p.ionml) /* A namelist. */ | |
454 | return false; | |
455 | return true; | |
456 | } | |
457 | ||
458 | ||
909087e0 | 459 | gfc_unit * |
4a8d4422 | 460 | set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind) |
6de9cd9a | 461 | { |
9370b3c0 | 462 | gfc_offset start_record = 0; |
6f34d6e0 | 463 | |
c08de9db | 464 | iunit->unit_number = dtp->common.unit; |
6f34d6e0 | 465 | iunit->recl = dtp->internal_unit_len; |
4a8d4422 JD |
466 | iunit->internal_unit = dtp->internal_unit; |
467 | iunit->internal_unit_len = dtp->internal_unit_len; | |
468 | iunit->internal_unit_kind = kind; | |
6de9cd9a | 469 | |
3b63b663 JD |
470 | /* As an optimization, adjust the unit record length to not |
471 | include trailing blanks. This will not work under certain conditions | |
472 | where trailing blanks have significance. */ | |
473 | if (dtp->u.p.mode == READING && is_trim_ok (dtp)) | |
474 | { | |
475 | int len; | |
4a8d4422 JD |
476 | if (kind == 1) |
477 | len = string_len_trim (iunit->internal_unit_len, | |
478 | iunit->internal_unit); | |
3b63b663 | 479 | else |
4a8d4422 JD |
480 | len = string_len_trim_char4 (iunit->internal_unit_len, |
481 | (const gfc_char4_t*) iunit->internal_unit); | |
482 | iunit->internal_unit_len = len; | |
483 | iunit->recl = iunit->internal_unit_len; | |
3b63b663 JD |
484 | } |
485 | ||
6f34d6e0 | 486 | /* Set up the looping specification from the array descriptor, if any. */ |
6de9cd9a | 487 | |
6f34d6e0 JD |
488 | if (is_array_io (dtp)) |
489 | { | |
490 | iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc); | |
491 | iunit->ls = (array_loop_spec *) | |
92e6f3a4 | 492 | xmallocarray (iunit->rank, sizeof (array_loop_spec)); |
4a8d4422 | 493 | iunit->internal_unit_len *= |
9370b3c0 TK |
494 | init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record); |
495 | ||
496 | start_record *= iunit->recl; | |
6de9cd9a DN |
497 | } |
498 | ||
6f34d6e0 | 499 | /* Set initial values for unit parameters. */ |
4a8d4422 JD |
500 | if (kind == 4) |
501 | iunit->s = open_internal4 (iunit->internal_unit - start_record, | |
502 | iunit->internal_unit_len, -start_record); | |
c7421e06 | 503 | else |
4a8d4422 JD |
504 | iunit->s = open_internal (iunit->internal_unit - start_record, |
505 | iunit->internal_unit_len, -start_record); | |
6f34d6e0 | 506 | |
6f34d6e0 JD |
507 | iunit->bytes_left = iunit->recl; |
508 | iunit->last_record=0; | |
509 | iunit->maxrec=0; | |
510 | iunit->current_record=0; | |
511 | iunit->read_bad = 0; | |
10256cbe | 512 | iunit->endfile = NO_ENDFILE; |
6f34d6e0 JD |
513 | |
514 | /* Set flags for the internal unit. */ | |
515 | ||
516 | iunit->flags.access = ACCESS_SEQUENTIAL; | |
517 | iunit->flags.action = ACTION_READWRITE; | |
8217a635 | 518 | iunit->flags.blank = BLANK_NULL; |
6f34d6e0 JD |
519 | iunit->flags.form = FORM_FORMATTED; |
520 | iunit->flags.pad = PAD_YES; | |
521 | iunit->flags.status = STATUS_UNSPECIFIED; | |
693ac2ab | 522 | iunit->flags.sign = SIGN_UNSPECIFIED; |
10256cbe | 523 | iunit->flags.decimal = DECIMAL_POINT; |
75b2dba9 | 524 | iunit->flags.delim = DELIM_UNSPECIFIED; |
10256cbe | 525 | iunit->flags.encoding = ENCODING_DEFAULT; |
931149a6 | 526 | iunit->flags.async = ASYNC_NO; |
37b659dd | 527 | iunit->flags.round = ROUND_UNSPECIFIED; |
6f34d6e0 JD |
528 | |
529 | /* Initialize the data transfer parameters. */ | |
530 | ||
531 | dtp->u.p.advance_status = ADVANCE_YES; | |
6f34d6e0 JD |
532 | dtp->u.p.seen_dollar = 0; |
533 | dtp->u.p.skips = 0; | |
534 | dtp->u.p.pending_spaces = 0; | |
535 | dtp->u.p.max_pos = 0; | |
807fb853 | 536 | dtp->u.p.at_eof = 0; |
6f34d6e0 JD |
537 | return iunit; |
538 | } | |
539 | ||
540 | ||
4a8d4422 JD |
541 | /* stash_internal_unit()-- Push the internal unit number onto the |
542 | avaialble stack. */ | |
54ffdb12 | 543 | void |
4a8d4422 | 544 | stash_internal_unit (st_parameter_dt *dtp) |
54ffdb12 | 545 | { |
4a8d4422 JD |
546 | __gthread_mutex_lock (&unit_lock); |
547 | newunit_tos++; | |
548 | if (newunit_tos >= NEWUNIT_STACK_SIZE) | |
549 | internal_error (&dtp->common, "stash_internal_unit(): Stack Size Exceeded"); | |
550 | newunit_stack[newunit_tos].unit_number = dtp->common.unit; | |
551 | newunit_stack[newunit_tos].unit = dtp->u.p.current_unit; | |
552 | __gthread_mutex_unlock (&unit_lock); | |
54ffdb12 | 553 | } |
e73d3ca6 | 554 | |
54ffdb12 JD |
555 | |
556 | ||
6f34d6e0 | 557 | /* get_unit()-- Returns the unit structure associated with the integer |
dcfddbd4 | 558 | unit or the internal file. */ |
6f34d6e0 JD |
559 | |
560 | gfc_unit * | |
561 | get_unit (st_parameter_dt *dtp, int do_create) | |
562 | { | |
f29876bb | 563 | gfc_unit *unit; |
6f34d6e0 JD |
564 | |
565 | if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0) | |
4a8d4422 JD |
566 | { |
567 | int kind; | |
568 | if (dtp->common.unit == GFC_INTERNAL_UNIT) | |
569 | kind = 1; | |
570 | else if (dtp->common.unit == GFC_INTERNAL_UNIT4) | |
571 | kind = 4; | |
572 | else | |
573 | internal_error (&dtp->common, "get_unit(): Bad internal unit KIND"); | |
6f34d6e0 | 574 | |
4a8d4422 JD |
575 | if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) != 0) |
576 | { | |
577 | dtp->u.p.unit_is_internal = 1; | |
c04d4ede | 578 | dtp->common.unit = newunit_alloc (); |
4a8d4422 JD |
579 | unit = get_gfc_unit (dtp->common.unit, do_create); |
580 | set_internal_unit (dtp, unit, kind); | |
581 | fbuf_init (unit, 128); | |
582 | return unit; | |
583 | } | |
584 | else | |
585 | { | |
586 | if (newunit_tos) | |
587 | { | |
588 | dtp->common.unit = newunit_stack[newunit_tos].unit_number; | |
589 | unit = newunit_stack[newunit_tos--].unit; | |
590 | unit->fbuf->act = unit->fbuf->pos = 0; | |
591 | } | |
592 | else | |
593 | { | |
c04d4ede | 594 | dtp->common.unit = newunit_alloc (); |
4a8d4422 JD |
595 | unit = xcalloc (1, sizeof (gfc_unit)); |
596 | fbuf_init (unit, 128); | |
597 | } | |
598 | set_internal_unit (dtp, unit, kind); | |
599 | return unit; | |
600 | } | |
601 | } | |
c08de9db JD |
602 | |
603 | /* If an internal unit number is passed from the parent to the child | |
604 | it should have been stashed on the newunit_stack ready to be used. | |
605 | Check for it now and return the internal unit if found. */ | |
606 | if (newunit_tos && (dtp->common.unit <= NEWUNIT_START) | |
607 | && (dtp->common.unit == newunit_stack[newunit_tos].unit_number)) | |
608 | { | |
609 | unit = newunit_stack[newunit_tos--].unit; | |
610 | return unit; | |
611 | } | |
612 | ||
dcfddbd4 | 613 | /* Has to be an external unit. */ |
6f34d6e0 | 614 | dtp->u.p.unit_is_internal = 0; |
4a8d4422 | 615 | dtp->internal_unit = NULL; |
54ffdb12 | 616 | dtp->internal_unit_desc = NULL; |
c08de9db | 617 | |
c04d4ede JB |
618 | /* For an external unit with unit number < 0 creating it on the fly |
619 | is not allowed, such units must be created with | |
620 | OPEN(NEWUNIT=...). */ | |
621 | if (dtp->common.unit < 0) | |
622 | return get_gfc_unit (dtp->common.unit, 0); | |
c08de9db | 623 | |
c04d4ede | 624 | return get_gfc_unit (dtp->common.unit, do_create); |
6de9cd9a DN |
625 | } |
626 | ||
627 | ||
6de9cd9a | 628 | /*************************/ |
dcfddbd4 | 629 | /* Initialize everything. */ |
6de9cd9a DN |
630 | |
631 | void | |
632 | init_units (void) | |
633 | { | |
909087e0 | 634 | gfc_unit *u; |
a0f94629 | 635 | unsigned int i; |
6de9cd9a | 636 | |
9cbecd06 JB |
637 | #ifdef HAVE_NEWLOCALE |
638 | c_locale = newlocale (0, "C", 0); | |
639 | #else | |
640 | #ifndef __GTHREAD_MUTEX_INIT | |
641 | __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock); | |
642 | #endif | |
643 | #endif | |
644 | ||
5e805e44 JJ |
645 | #ifndef __GTHREAD_MUTEX_INIT |
646 | __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock); | |
647 | #endif | |
648 | ||
6de9cd9a DN |
649 | if (options.stdin_unit >= 0) |
650 | { /* STDIN */ | |
5e805e44 | 651 | u = insert_unit (options.stdin_unit); |
6de9cd9a DN |
652 | u->s = input_stream (); |
653 | ||
654 | u->flags.action = ACTION_READ; | |
655 | ||
656 | u->flags.access = ACCESS_SEQUENTIAL; | |
657 | u->flags.form = FORM_FORMATTED; | |
658 | u->flags.status = STATUS_OLD; | |
ee17607a JD |
659 | u->flags.blank = BLANK_NULL; |
660 | u->flags.pad = PAD_YES; | |
6de9cd9a | 661 | u->flags.position = POSITION_ASIS; |
693ac2ab | 662 | u->flags.sign = SIGN_UNSPECIFIED; |
10256cbe | 663 | u->flags.decimal = DECIMAL_POINT; |
d520fea8 | 664 | u->flags.delim = DELIM_UNSPECIFIED; |
10256cbe | 665 | u->flags.encoding = ENCODING_DEFAULT; |
931149a6 | 666 | u->flags.async = ASYNC_NO; |
37b659dd | 667 | u->flags.round = ROUND_UNSPECIFIED; |
0ef33d44 FR |
668 | u->flags.share = SHARE_UNSPECIFIED; |
669 | u->flags.cc = CC_LIST; | |
e73d3ca6 | 670 | |
6de9cd9a DN |
671 | u->recl = options.default_recl; |
672 | u->endfile = NO_ENDFILE; | |
673 | ||
0e05c303 | 674 | u->filename = strdup (stdin_name); |
7812c78c JD |
675 | |
676 | fbuf_init (u, 0); | |
e73d3ca6 | 677 | |
5e805e44 | 678 | __gthread_mutex_unlock (&u->lock); |
6de9cd9a DN |
679 | } |
680 | ||
681 | if (options.stdout_unit >= 0) | |
682 | { /* STDOUT */ | |
5e805e44 | 683 | u = insert_unit (options.stdout_unit); |
6de9cd9a DN |
684 | u->s = output_stream (); |
685 | ||
686 | u->flags.action = ACTION_WRITE; | |
687 | ||
688 | u->flags.access = ACCESS_SEQUENTIAL; | |
689 | u->flags.form = FORM_FORMATTED; | |
690 | u->flags.status = STATUS_OLD; | |
ee17607a | 691 | u->flags.blank = BLANK_NULL; |
6de9cd9a | 692 | u->flags.position = POSITION_ASIS; |
693ac2ab | 693 | u->flags.sign = SIGN_UNSPECIFIED; |
10256cbe | 694 | u->flags.decimal = DECIMAL_POINT; |
75b2dba9 | 695 | u->flags.delim = DELIM_UNSPECIFIED; |
10256cbe | 696 | u->flags.encoding = ENCODING_DEFAULT; |
931149a6 | 697 | u->flags.async = ASYNC_NO; |
37b659dd | 698 | u->flags.round = ROUND_UNSPECIFIED; |
0ef33d44 FR |
699 | u->flags.share = SHARE_UNSPECIFIED; |
700 | u->flags.cc = CC_LIST; | |
6de9cd9a DN |
701 | |
702 | u->recl = options.default_recl; | |
fbac3363 | 703 | u->endfile = AT_ENDFILE; |
e73d3ca6 | 704 | |
0e05c303 | 705 | u->filename = strdup (stdout_name); |
e73d3ca6 | 706 | |
15877a88 | 707 | fbuf_init (u, 0); |
fbac3363 | 708 | |
5e805e44 | 709 | __gthread_mutex_unlock (&u->lock); |
fbac3363 DE |
710 | } |
711 | ||
712 | if (options.stderr_unit >= 0) | |
713 | { /* STDERR */ | |
5e805e44 | 714 | u = insert_unit (options.stderr_unit); |
fbac3363 DE |
715 | u->s = error_stream (); |
716 | ||
717 | u->flags.action = ACTION_WRITE; | |
718 | ||
719 | u->flags.access = ACCESS_SEQUENTIAL; | |
720 | u->flags.form = FORM_FORMATTED; | |
721 | u->flags.status = STATUS_OLD; | |
ee17607a | 722 | u->flags.blank = BLANK_NULL; |
fbac3363 | 723 | u->flags.position = POSITION_ASIS; |
693ac2ab | 724 | u->flags.sign = SIGN_UNSPECIFIED; |
10256cbe JD |
725 | u->flags.decimal = DECIMAL_POINT; |
726 | u->flags.encoding = ENCODING_DEFAULT; | |
931149a6 | 727 | u->flags.async = ASYNC_NO; |
37b659dd | 728 | u->flags.round = ROUND_UNSPECIFIED; |
0ef33d44 FR |
729 | u->flags.share = SHARE_UNSPECIFIED; |
730 | u->flags.cc = CC_LIST; | |
fbac3363 DE |
731 | |
732 | u->recl = options.default_recl; | |
6de9cd9a DN |
733 | u->endfile = AT_ENDFILE; |
734 | ||
0e05c303 | 735 | u->filename = strdup (stderr_name); |
e73d3ca6 | 736 | |
15877a88 JB |
737 | fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing |
738 | any kind of exotic formatting to stderr. */ | |
87557722 | 739 | |
5e805e44 | 740 | __gthread_mutex_unlock (&u->lock); |
6de9cd9a DN |
741 | } |
742 | ||
743 | /* Calculate the maximum file offset in a portable manner. | |
dcfddbd4 JD |
744 | max will be the largest signed number for the type gfc_offset. |
745 | set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */ | |
5e805e44 JJ |
746 | max_offset = 0; |
747 | for (i = 0; i < sizeof (max_offset) * 8 - 1; i++) | |
748 | max_offset = max_offset + ((gfc_offset) 1 << i); | |
4a8d4422 JD |
749 | |
750 | /* Initialize the newunit stack. */ | |
751 | memset (newunit_stack, 0, NEWUNIT_STACK_SIZE * sizeof(gfc_saved_unit)); | |
752 | newunit_tos = 0; | |
6de9cd9a DN |
753 | } |
754 | ||
755 | ||
5e805e44 JJ |
756 | static int |
757 | close_unit_1 (gfc_unit *u, int locked) | |
6de9cd9a DN |
758 | { |
759 | int i, rc; | |
e73d3ca6 | 760 | |
13846929 JD |
761 | /* If there are previously written bytes from a write with ADVANCE="no" |
762 | Reposition the buffer before closing. */ | |
108bc190 TK |
763 | if (u->previous_nonadvancing_write) |
764 | finish_last_advance_record (u); | |
13846929 | 765 | |
2ac7316d | 766 | rc = (u->s == NULL) ? 0 : sclose (u->s) == -1; |
5e805e44 JJ |
767 | |
768 | u->closed = 1; | |
769 | if (!locked) | |
770 | __gthread_mutex_lock (&unit_lock); | |
771 | ||
6de9cd9a DN |
772 | for (i = 0; i < CACHE_SIZE; i++) |
773 | if (unit_cache[i] == u) | |
774 | unit_cache[i] = NULL; | |
775 | ||
6de9cd9a | 776 | delete_unit (u); |
5e805e44 | 777 | |
0e05c303 JB |
778 | free (u->filename); |
779 | u->filename = NULL; | |
7812c78c | 780 | |
e73d3ca6 | 781 | free_format_hash_table (u); |
15877a88 | 782 | fbuf_destroy (u); |
5e805e44 | 783 | |
c04d4ede JB |
784 | if (u->unit_number <= NEWUNIT_START) |
785 | newunit_free (u->unit_number); | |
786 | ||
5e805e44 JJ |
787 | if (!locked) |
788 | __gthread_mutex_unlock (&u->lock); | |
789 | ||
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 | |
792 | instead. */ | |
793 | if (u->waiting == 0) | |
ef4195d6 | 794 | destroy_unit_mutex (u); |
5e805e44 JJ |
795 | |
796 | if (!locked) | |
797 | __gthread_mutex_unlock (&unit_lock); | |
6de9cd9a DN |
798 | |
799 | return rc; | |
800 | } | |
801 | ||
5e805e44 JJ |
802 | void |
803 | unlock_unit (gfc_unit *u) | |
804 | { | |
805 | __gthread_mutex_unlock (&u->lock); | |
806 | } | |
807 | ||
808 | /* close_unit()-- Close a unit. The stream is closed, and any memory | |
dcfddbd4 JD |
809 | associated with the stream is freed. Returns nonzero on I/O error. |
810 | Should be called with the u->lock locked. */ | |
5e805e44 JJ |
811 | |
812 | int | |
813 | close_unit (gfc_unit *u) | |
814 | { | |
815 | return close_unit_1 (u, 0); | |
816 | } | |
817 | ||
6de9cd9a DN |
818 | |
819 | /* close_units()-- Delete units on completion. We just keep deleting | |
dcfddbd4 JD |
820 | the root of the treap until there is nothing left. |
821 | Not sure what to do with locking here. Some other thread might be | |
822 | holding some unit's lock and perhaps hold it indefinitely | |
823 | (e.g. waiting for input from some pipe) and close_units shouldn't | |
824 | delay the program too much. */ | |
6de9cd9a DN |
825 | |
826 | void | |
827 | close_units (void) | |
828 | { | |
5e805e44 JJ |
829 | __gthread_mutex_lock (&unit_lock); |
830 | while (unit_root != NULL) | |
831 | close_unit_1 (unit_root, 1); | |
832 | __gthread_mutex_unlock (&unit_lock); | |
9cbecd06 | 833 | |
4a8d4422 JD |
834 | while (newunit_tos != 0) |
835 | if (newunit_stack[newunit_tos].unit) | |
836 | { | |
837 | fbuf_destroy (newunit_stack[newunit_tos].unit); | |
838 | free (newunit_stack[newunit_tos].unit->s); | |
839 | free (newunit_stack[newunit_tos--].unit); | |
840 | } | |
c04d4ede JB |
841 | |
842 | free (newunits); | |
843 | ||
9cbecd06 JB |
844 | #ifdef HAVE_FREELOCALE |
845 | freelocale (c_locale); | |
846 | #endif | |
6de9cd9a | 847 | } |
16d962d9 JD |
848 | |
849 | ||
7d5ee219 JB |
850 | /* High level interface to truncate a file, i.e. flush format buffers, |
851 | and generate an error or set some flags. Just like POSIX | |
852 | ftruncate, returns 0 on success, -1 on failure. */ | |
7812c78c JD |
853 | |
854 | int | |
f29876bb | 855 | unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common) |
7812c78c JD |
856 | { |
857 | int ret; | |
858 | ||
859 | /* Make sure format buffer is flushed. */ | |
860 | if (u->flags.form == FORM_FORMATTED) | |
861 | { | |
862 | if (u->mode == READING) | |
863 | pos += fbuf_reset (u); | |
864 | else | |
865 | fbuf_flush (u, u->mode); | |
866 | } | |
e73d3ca6 | 867 | |
7812c78c JD |
868 | /* struncate() should flush the stream buffer if necessary, so don't |
869 | bother calling sflush() here. */ | |
870 | ret = struncate (u->s, pos); | |
871 | ||
872 | if (ret != 0) | |
7d5ee219 | 873 | generate_error (common, LIBERROR_OS, NULL); |
7812c78c JD |
874 | else |
875 | { | |
876 | u->endfile = AT_ENDFILE; | |
877 | u->flags.position = POSITION_APPEND; | |
878 | } | |
879 | ||
880 | return ret; | |
881 | } | |
882 | ||
883 | ||
87557722 JD |
884 | /* filename_from_unit()-- If the unit_number exists, return a pointer to the |
885 | name of the associated file, otherwise return the empty string. The caller | |
886 | must free memory allocated for the filename string. */ | |
887 | ||
888 | char * | |
8eacc23d | 889 | filename_from_unit (int n) |
87557722 | 890 | { |
8eacc23d SK |
891 | gfc_unit *u; |
892 | int c; | |
893 | ||
894 | /* Find the unit. */ | |
895 | u = unit_root; | |
896 | while (u != NULL) | |
897 | { | |
898 | c = compare (n, u->unit_number); | |
899 | if (c < 0) | |
900 | u = u->left; | |
901 | if (c > 0) | |
902 | u = u->right; | |
903 | if (c == 0) | |
904 | break; | |
905 | } | |
906 | ||
907 | /* Get the filename. */ | |
7165d8f1 | 908 | if (u != NULL && u->filename != NULL) |
0e05c303 | 909 | return strdup (u->filename); |
87557722 JD |
910 | else |
911 | return (char *) NULL; | |
8eacc23d SK |
912 | } |
913 | ||
108bc190 TK |
914 | void |
915 | finish_last_advance_record (gfc_unit *u) | |
916 | { | |
e73d3ca6 | 917 | |
108bc190 | 918 | if (u->saved_pos > 0) |
7812c78c | 919 | fbuf_seek (u, u->saved_pos, SEEK_CUR); |
108bc190 TK |
920 | |
921 | if (!(u->unit_number == options.stdout_unit | |
922 | || u->unit_number == options.stderr_unit)) | |
923 | { | |
108bc190 | 924 | #ifdef HAVE_CRLF |
7812c78c | 925 | const int len = 2; |
108bc190 | 926 | #else |
7812c78c | 927 | const int len = 1; |
108bc190 | 928 | #endif |
7812c78c JD |
929 | char *p = fbuf_alloc (u, len); |
930 | if (!p) | |
108bc190 | 931 | os_error ("Completing record after ADVANCE_NO failed"); |
7812c78c JD |
932 | #ifdef HAVE_CRLF |
933 | *(p++) = '\r'; | |
934 | #endif | |
935 | *p = '\n'; | |
108bc190 | 936 | } |
7812c78c JD |
937 | |
938 | fbuf_flush (u, u->mode); | |
108bc190 TK |
939 | } |
940 | ||
c04d4ede | 941 | |
4a8d4422 JD |
942 | /* Assign a negative number for NEWUNIT in OPEN statements or for |
943 | internal units. */ | |
c04d4ede JB |
944 | int |
945 | newunit_alloc (void) | |
dcfddbd4 | 946 | { |
dcfddbd4 | 947 | __gthread_mutex_lock (&unit_lock); |
c04d4ede | 948 | if (!newunits) |
dcfddbd4 | 949 | { |
c04d4ede JB |
950 | newunits = xcalloc (16, 1); |
951 | newunit_size = 16; | |
dcfddbd4 | 952 | } |
c04d4ede JB |
953 | |
954 | /* Search for the next available newunit. */ | |
955 | for (int ii = newunit_lwi; ii < newunit_size; ii++) | |
956 | { | |
957 | if (!newunits[ii]) | |
958 | { | |
959 | newunits[ii] = true; | |
960 | newunit_lwi = ii + 1; | |
961 | __gthread_mutex_unlock (&unit_lock); | |
962 | return -ii + NEWUNIT_START; | |
963 | } | |
964 | } | |
965 | ||
966 | /* Search failed, bump size of array and allocate the first | |
967 | available unit. */ | |
968 | int old_size = newunit_size; | |
969 | newunit_size *= 2; | |
970 | newunits = xrealloc (newunits, newunit_size); | |
971 | memset (newunits + old_size, 0, old_size); | |
972 | newunits[old_size] = true; | |
973 | newunit_lwi = old_size + 1; | |
974 | __gthread_mutex_unlock (&unit_lock); | |
975 | return -old_size + NEWUNIT_START; | |
976 | } | |
977 | ||
978 | ||
979 | /* Free a previously allocated newunit= unit number. unit_lock must | |
980 | be held when calling. */ | |
981 | ||
982 | static void | |
983 | newunit_free (int unit) | |
984 | { | |
985 | int ind = -unit + NEWUNIT_START; | |
986 | assert(ind >= 0 && ind < newunit_size); | |
987 | newunits[ind] = false; | |
988 | if (ind < newunit_lwi) | |
989 | newunit_lwi = ind; | |
dcfddbd4 | 990 | } |