]>
Commit | Line | Data |
---|---|---|
f0bcf628 | 1 | /* Copyright (C) 2002-2014 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 DN |
30 | #include <stdlib.h> |
31 | #include <string.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 DN |
71 | /* Subroutines related to units */ |
72 | ||
ea5e3c04 | 73 | /* Unit number to be assigned when NEWUNIT is used in an OPEN statement. */ |
dcfddbd4 | 74 | #define GFC_FIRST_NEWUNIT -10 |
ea5e3c04 | 75 | static GFC_INTEGER_4 next_available_newunit = GFC_FIRST_NEWUNIT; |
6de9cd9a DN |
76 | |
77 | #define CACHE_SIZE 3 | |
6f34d6e0 | 78 | static gfc_unit *unit_cache[CACHE_SIZE]; |
5e805e44 JJ |
79 | gfc_offset max_offset; |
80 | gfc_unit *unit_root; | |
81 | #ifdef __GTHREAD_MUTEX_INIT | |
82 | __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT; | |
83 | #else | |
84 | __gthread_mutex_t unit_lock; | |
85 | #endif | |
6de9cd9a | 86 | |
87557722 JD |
87 | /* We use these filenames for error reporting. */ |
88 | ||
89 | static char stdin_name[] = "stdin"; | |
90 | static char stdout_name[] = "stdout"; | |
91 | static char stderr_name[] = "stderr"; | |
92 | ||
6de9cd9a DN |
93 | /* This implementation is based on Stefan Nilsson's article in the |
94 | * July 1997 Doctor Dobb's Journal, "Treaps in Java". */ | |
95 | ||
96 | /* pseudo_random()-- Simple linear congruential pseudorandom number | |
97 | * generator. The period of this generator is 44071, which is plenty | |
98 | * for our purposes. */ | |
99 | ||
100 | static int | |
101 | pseudo_random (void) | |
102 | { | |
103 | static int x0 = 5341; | |
104 | ||
105 | x0 = (22611 * x0 + 10) % 44071; | |
106 | return x0; | |
107 | } | |
108 | ||
109 | ||
110 | /* rotate_left()-- Rotate the treap left */ | |
111 | ||
909087e0 TS |
112 | static gfc_unit * |
113 | rotate_left (gfc_unit * t) | |
6de9cd9a | 114 | { |
909087e0 | 115 | gfc_unit *temp; |
6de9cd9a DN |
116 | |
117 | temp = t->right; | |
118 | t->right = t->right->left; | |
119 | temp->left = t; | |
120 | ||
121 | return temp; | |
122 | } | |
123 | ||
124 | ||
125 | /* rotate_right()-- Rotate the treap right */ | |
126 | ||
909087e0 TS |
127 | static gfc_unit * |
128 | rotate_right (gfc_unit * t) | |
6de9cd9a | 129 | { |
909087e0 | 130 | gfc_unit *temp; |
6de9cd9a DN |
131 | |
132 | temp = t->left; | |
133 | t->left = t->left->right; | |
134 | temp->right = t; | |
135 | ||
136 | return temp; | |
137 | } | |
138 | ||
139 | ||
6de9cd9a DN |
140 | static int |
141 | compare (int a, int b) | |
142 | { | |
6de9cd9a DN |
143 | if (a < b) |
144 | return -1; | |
145 | if (a > b) | |
146 | return 1; | |
147 | ||
148 | return 0; | |
149 | } | |
150 | ||
151 | ||
152 | /* insert()-- Recursive insertion function. Returns the updated treap. */ | |
153 | ||
909087e0 | 154 | static gfc_unit * |
5e805e44 | 155 | insert (gfc_unit *new, gfc_unit *t) |
6de9cd9a DN |
156 | { |
157 | int c; | |
158 | ||
159 | if (t == NULL) | |
160 | return new; | |
161 | ||
162 | c = compare (new->unit_number, t->unit_number); | |
163 | ||
164 | if (c < 0) | |
165 | { | |
166 | t->left = insert (new, t->left); | |
167 | if (t->priority < t->left->priority) | |
168 | t = rotate_right (t); | |
169 | } | |
170 | ||
171 | if (c > 0) | |
172 | { | |
173 | t->right = insert (new, t->right); | |
174 | if (t->priority < t->right->priority) | |
175 | t = rotate_left (t); | |
176 | } | |
177 | ||
178 | if (c == 0) | |
5e805e44 | 179 | internal_error (NULL, "insert(): Duplicate key found!"); |
6de9cd9a DN |
180 | |
181 | return t; | |
182 | } | |
183 | ||
184 | ||
5e805e44 | 185 | /* insert_unit()-- Create a new node, insert it into the treap. */ |
6de9cd9a | 186 | |
5e805e44 JJ |
187 | static gfc_unit * |
188 | insert_unit (int n) | |
6de9cd9a | 189 | { |
f4471acb | 190 | gfc_unit *u = xcalloc (1, sizeof (gfc_unit)); |
5e805e44 JJ |
191 | u->unit_number = n; |
192 | #ifdef __GTHREAD_MUTEX_INIT | |
193 | { | |
194 | __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT; | |
195 | u->lock = tmp; | |
196 | } | |
197 | #else | |
198 | __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock); | |
199 | #endif | |
200 | __gthread_mutex_lock (&u->lock); | |
201 | u->priority = pseudo_random (); | |
202 | unit_root = insert (u, unit_root); | |
203 | return u; | |
6de9cd9a DN |
204 | } |
205 | ||
206 | ||
ef4195d6 JD |
207 | /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */ |
208 | ||
209 | static void | |
210 | destroy_unit_mutex (gfc_unit * u) | |
211 | { | |
4dabf736 | 212 | __gthread_mutex_destroy (&u->lock); |
bb408e87 | 213 | free (u); |
ef4195d6 JD |
214 | } |
215 | ||
216 | ||
909087e0 TS |
217 | static gfc_unit * |
218 | delete_root (gfc_unit * t) | |
6de9cd9a | 219 | { |
909087e0 | 220 | gfc_unit *temp; |
6de9cd9a DN |
221 | |
222 | if (t->left == NULL) | |
223 | return t->right; | |
224 | if (t->right == NULL) | |
225 | return t->left; | |
226 | ||
227 | if (t->left->priority > t->right->priority) | |
228 | { | |
229 | temp = rotate_right (t); | |
230 | temp->right = delete_root (t); | |
231 | } | |
232 | else | |
233 | { | |
234 | temp = rotate_left (t); | |
235 | temp->left = delete_root (t); | |
236 | } | |
237 | ||
238 | return temp; | |
239 | } | |
240 | ||
241 | ||
242 | /* delete_treap()-- Delete an element from a tree. The 'old' value | |
243 | * does not necessarily have to point to the element to be deleted, it | |
244 | * must just point to a treap structure with the key to be deleted. | |
245 | * Returns the new root node of the tree. */ | |
246 | ||
909087e0 TS |
247 | static gfc_unit * |
248 | delete_treap (gfc_unit * old, gfc_unit * t) | |
6de9cd9a DN |
249 | { |
250 | int c; | |
251 | ||
252 | if (t == NULL) | |
253 | return NULL; | |
254 | ||
255 | c = compare (old->unit_number, t->unit_number); | |
256 | ||
257 | if (c < 0) | |
258 | t->left = delete_treap (old, t->left); | |
259 | if (c > 0) | |
260 | t->right = delete_treap (old, t->right); | |
261 | if (c == 0) | |
262 | t = delete_root (t); | |
263 | ||
264 | return t; | |
265 | } | |
266 | ||
267 | ||
268 | /* delete_unit()-- Delete a unit from a tree */ | |
269 | ||
270 | static void | |
909087e0 | 271 | delete_unit (gfc_unit * old) |
6de9cd9a | 272 | { |
5e805e44 | 273 | unit_root = delete_treap (old, unit_root); |
6de9cd9a DN |
274 | } |
275 | ||
276 | ||
6f34d6e0 | 277 | /* get_external_unit()-- Given an integer, return a pointer to the unit |
5e805e44 JJ |
278 | * structure. Returns NULL if the unit does not exist, |
279 | * otherwise returns a locked unit. */ | |
6de9cd9a | 280 | |
5e805e44 | 281 | static gfc_unit * |
6f34d6e0 | 282 | get_external_unit (int n, int do_create) |
6de9cd9a | 283 | { |
909087e0 | 284 | gfc_unit *p; |
5e805e44 | 285 | int c, created = 0; |
6de9cd9a | 286 | |
5e805e44 JJ |
287 | __gthread_mutex_lock (&unit_lock); |
288 | retry: | |
6de9cd9a DN |
289 | for (c = 0; c < CACHE_SIZE; c++) |
290 | if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n) | |
291 | { | |
292 | p = unit_cache[c]; | |
5e805e44 | 293 | goto found; |
6de9cd9a DN |
294 | } |
295 | ||
5e805e44 | 296 | p = unit_root; |
6de9cd9a DN |
297 | while (p != NULL) |
298 | { | |
299 | c = compare (n, p->unit_number); | |
300 | if (c < 0) | |
301 | p = p->left; | |
302 | if (c > 0) | |
303 | p = p->right; | |
304 | if (c == 0) | |
305 | break; | |
306 | } | |
307 | ||
5e805e44 JJ |
308 | if (p == NULL && do_create) |
309 | { | |
310 | p = insert_unit (n); | |
311 | created = 1; | |
312 | } | |
313 | ||
6de9cd9a DN |
314 | if (p != NULL) |
315 | { | |
316 | for (c = 0; c < CACHE_SIZE - 1; c++) | |
317 | unit_cache[c] = unit_cache[c + 1]; | |
318 | ||
319 | unit_cache[CACHE_SIZE - 1] = p; | |
320 | } | |
321 | ||
5e805e44 JJ |
322 | if (created) |
323 | { | |
324 | /* Newly created units have their lock held already | |
325 | from insert_unit. Just unlock UNIT_LOCK and return. */ | |
326 | __gthread_mutex_unlock (&unit_lock); | |
327 | return p; | |
328 | } | |
329 | ||
330 | found: | |
331 | if (p != NULL) | |
332 | { | |
333 | /* Fast path. */ | |
334 | if (! __gthread_mutex_trylock (&p->lock)) | |
335 | { | |
336 | /* assert (p->closed == 0); */ | |
337 | __gthread_mutex_unlock (&unit_lock); | |
338 | return p; | |
339 | } | |
340 | ||
341 | inc_waiting_locked (p); | |
342 | } | |
343 | ||
344 | __gthread_mutex_unlock (&unit_lock); | |
345 | ||
346 | if (p != NULL) | |
347 | { | |
348 | __gthread_mutex_lock (&p->lock); | |
349 | if (p->closed) | |
350 | { | |
351 | __gthread_mutex_lock (&unit_lock); | |
352 | __gthread_mutex_unlock (&p->lock); | |
353 | if (predec_waiting_locked (p) == 0) | |
ef4195d6 | 354 | destroy_unit_mutex (p); |
5e805e44 JJ |
355 | goto retry; |
356 | } | |
357 | ||
358 | dec_waiting_unlocked (p); | |
359 | } | |
6de9cd9a DN |
360 | return p; |
361 | } | |
362 | ||
6f34d6e0 | 363 | |
5e805e44 JJ |
364 | gfc_unit * |
365 | find_unit (int n) | |
366 | { | |
6f34d6e0 | 367 | return get_external_unit (n, 0); |
5e805e44 JJ |
368 | } |
369 | ||
6f34d6e0 | 370 | |
5e805e44 JJ |
371 | gfc_unit * |
372 | find_or_create_unit (int n) | |
373 | { | |
6f34d6e0 | 374 | return get_external_unit (n, 1); |
5e805e44 JJ |
375 | } |
376 | ||
6de9cd9a | 377 | |
3b63b663 JD |
378 | /* Helper function to check rank, stride, format string, and namelist. |
379 | This is used for optimization. You can't trim out blanks or shorten | |
380 | the string if trailing spaces are significant. */ | |
381 | static bool | |
382 | is_trim_ok (st_parameter_dt *dtp) | |
383 | { | |
384 | /* Check rank and stride. */ | |
861b2d2c | 385 | if (dtp->internal_unit_desc) |
3b63b663 JD |
386 | return false; |
387 | /* Format strings can not have 'BZ' or '/'. */ | |
388 | if (dtp->common.flags & IOPARM_DT_HAS_FORMAT) | |
389 | { | |
390 | char *p = dtp->format; | |
391 | off_t i; | |
392 | if (dtp->common.flags & IOPARM_DT_HAS_BLANK) | |
393 | return false; | |
394 | for (i = 0; i < dtp->format_len; i++) | |
395 | { | |
396 | if (p[i] == '/') return false; | |
397 | if (p[i] == 'b' || p[i] == 'B') | |
398 | if (p[i+1] == 'z' || p[i+1] == 'Z') | |
399 | return false; | |
400 | } | |
401 | } | |
402 | if (dtp->u.p.ionml) /* A namelist. */ | |
403 | return false; | |
404 | return true; | |
405 | } | |
406 | ||
407 | ||
909087e0 | 408 | gfc_unit * |
6f34d6e0 | 409 | get_internal_unit (st_parameter_dt *dtp) |
6de9cd9a | 410 | { |
6f34d6e0 | 411 | gfc_unit * iunit; |
9370b3c0 | 412 | gfc_offset start_record = 0; |
6f34d6e0 JD |
413 | |
414 | /* Allocate memory for a unit structure. */ | |
415 | ||
f4471acb | 416 | iunit = xcalloc (1, sizeof (gfc_unit)); |
5e805e44 | 417 | |
9b7e4f4f JDA |
418 | #ifdef __GTHREAD_MUTEX_INIT |
419 | { | |
420 | __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT; | |
421 | iunit->lock = tmp; | |
422 | } | |
423 | #else | |
424 | __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock); | |
425 | #endif | |
426 | __gthread_mutex_lock (&iunit->lock); | |
59154ed2 | 427 | |
6f34d6e0 | 428 | iunit->recl = dtp->internal_unit_len; |
79617d7e | 429 | |
54ffdb12 JD |
430 | /* For internal units we set the unit number to -1. |
431 | Otherwise internal units can be mistaken for a pre-connected unit or | |
432 | some other file I/O unit. */ | |
433 | iunit->unit_number = -1; | |
6de9cd9a | 434 | |
3b63b663 JD |
435 | /* As an optimization, adjust the unit record length to not |
436 | include trailing blanks. This will not work under certain conditions | |
437 | where trailing blanks have significance. */ | |
438 | if (dtp->u.p.mode == READING && is_trim_ok (dtp)) | |
439 | { | |
440 | int len; | |
441 | if (dtp->common.unit == 0) | |
442 | len = string_len_trim (dtp->internal_unit_len, | |
443 | dtp->internal_unit); | |
444 | else | |
445 | len = string_len_trim_char4 (dtp->internal_unit_len, | |
446 | (const gfc_char4_t*) dtp->internal_unit); | |
447 | dtp->internal_unit_len = len; | |
448 | iunit->recl = dtp->internal_unit_len; | |
449 | } | |
450 | ||
6f34d6e0 | 451 | /* Set up the looping specification from the array descriptor, if any. */ |
6de9cd9a | 452 | |
6f34d6e0 JD |
453 | if (is_array_io (dtp)) |
454 | { | |
455 | iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc); | |
456 | iunit->ls = (array_loop_spec *) | |
92e6f3a4 | 457 | xmallocarray (iunit->rank, sizeof (array_loop_spec)); |
6f34d6e0 | 458 | dtp->internal_unit_len *= |
9370b3c0 TK |
459 | init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record); |
460 | ||
461 | start_record *= iunit->recl; | |
6de9cd9a DN |
462 | } |
463 | ||
6f34d6e0 | 464 | /* Set initial values for unit parameters. */ |
c7421e06 | 465 | if (dtp->common.unit) |
74db2a47 JD |
466 | { |
467 | iunit->s = open_internal4 (dtp->internal_unit - start_record, | |
468 | dtp->internal_unit_len, -start_record); | |
469 | fbuf_init (iunit, 256); | |
470 | } | |
c7421e06 JD |
471 | else |
472 | iunit->s = open_internal (dtp->internal_unit - start_record, | |
473 | dtp->internal_unit_len, -start_record); | |
6f34d6e0 | 474 | |
6f34d6e0 JD |
475 | iunit->bytes_left = iunit->recl; |
476 | iunit->last_record=0; | |
477 | iunit->maxrec=0; | |
478 | iunit->current_record=0; | |
479 | iunit->read_bad = 0; | |
10256cbe | 480 | iunit->endfile = NO_ENDFILE; |
6f34d6e0 JD |
481 | |
482 | /* Set flags for the internal unit. */ | |
483 | ||
484 | iunit->flags.access = ACCESS_SEQUENTIAL; | |
485 | iunit->flags.action = ACTION_READWRITE; | |
8217a635 | 486 | iunit->flags.blank = BLANK_NULL; |
6f34d6e0 JD |
487 | iunit->flags.form = FORM_FORMATTED; |
488 | iunit->flags.pad = PAD_YES; | |
489 | iunit->flags.status = STATUS_UNSPECIFIED; | |
10256cbe JD |
490 | iunit->flags.sign = SIGN_SUPPRESS; |
491 | iunit->flags.decimal = DECIMAL_POINT; | |
75b2dba9 | 492 | iunit->flags.delim = DELIM_UNSPECIFIED; |
10256cbe | 493 | iunit->flags.encoding = ENCODING_DEFAULT; |
931149a6 | 494 | iunit->flags.async = ASYNC_NO; |
37b659dd | 495 | iunit->flags.round = ROUND_UNSPECIFIED; |
6f34d6e0 JD |
496 | |
497 | /* Initialize the data transfer parameters. */ | |
498 | ||
499 | dtp->u.p.advance_status = ADVANCE_YES; | |
6f34d6e0 JD |
500 | dtp->u.p.seen_dollar = 0; |
501 | dtp->u.p.skips = 0; | |
502 | dtp->u.p.pending_spaces = 0; | |
503 | dtp->u.p.max_pos = 0; | |
807fb853 | 504 | dtp->u.p.at_eof = 0; |
6f34d6e0 JD |
505 | |
506 | /* This flag tells us the unit is assigned to internal I/O. */ | |
507 | ||
508 | dtp->u.p.unit_is_internal = 1; | |
509 | ||
510 | return iunit; | |
511 | } | |
512 | ||
513 | ||
54ffdb12 JD |
514 | /* free_internal_unit()-- Free memory allocated for internal units if any. */ |
515 | void | |
516 | free_internal_unit (st_parameter_dt *dtp) | |
517 | { | |
518 | if (!is_internal_unit (dtp)) | |
519 | return; | |
520 | ||
74db2a47 JD |
521 | if (unlikely (is_char4_unit (dtp))) |
522 | fbuf_destroy (dtp->u.p.current_unit); | |
523 | ||
54ffdb12 | 524 | if (dtp->u.p.current_unit != NULL) |
ef4195d6 | 525 | { |
04695783 | 526 | free (dtp->u.p.current_unit->ls); |
ef4195d6 | 527 | |
04695783 | 528 | free (dtp->u.p.current_unit->s); |
ef4195d6 JD |
529 | |
530 | destroy_unit_mutex (dtp->u.p.current_unit); | |
531 | } | |
54ffdb12 | 532 | } |
ef4195d6 | 533 | |
54ffdb12 JD |
534 | |
535 | ||
6f34d6e0 | 536 | /* get_unit()-- Returns the unit structure associated with the integer |
dcfddbd4 | 537 | unit or the internal file. */ |
6f34d6e0 JD |
538 | |
539 | gfc_unit * | |
540 | get_unit (st_parameter_dt *dtp, int do_create) | |
541 | { | |
542 | ||
543 | if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0) | |
74db2a47 | 544 | return get_internal_unit (dtp); |
6f34d6e0 | 545 | |
dcfddbd4 | 546 | /* Has to be an external unit. */ |
6de9cd9a | 547 | |
6f34d6e0 | 548 | dtp->u.p.unit_is_internal = 0; |
54ffdb12 | 549 | dtp->internal_unit_desc = NULL; |
6f34d6e0 JD |
550 | |
551 | return get_external_unit (dtp->common.unit, do_create); | |
6de9cd9a DN |
552 | } |
553 | ||
554 | ||
6de9cd9a | 555 | /*************************/ |
dcfddbd4 | 556 | /* Initialize everything. */ |
6de9cd9a DN |
557 | |
558 | void | |
559 | init_units (void) | |
560 | { | |
909087e0 | 561 | gfc_unit *u; |
a0f94629 | 562 | unsigned int i; |
6de9cd9a | 563 | |
5e805e44 JJ |
564 | #ifndef __GTHREAD_MUTEX_INIT |
565 | __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock); | |
566 | #endif | |
567 | ||
6de9cd9a DN |
568 | if (options.stdin_unit >= 0) |
569 | { /* STDIN */ | |
5e805e44 | 570 | u = insert_unit (options.stdin_unit); |
6de9cd9a DN |
571 | u->s = input_stream (); |
572 | ||
573 | u->flags.action = ACTION_READ; | |
574 | ||
575 | u->flags.access = ACCESS_SEQUENTIAL; | |
576 | u->flags.form = FORM_FORMATTED; | |
577 | u->flags.status = STATUS_OLD; | |
ee17607a JD |
578 | u->flags.blank = BLANK_NULL; |
579 | u->flags.pad = PAD_YES; | |
6de9cd9a | 580 | u->flags.position = POSITION_ASIS; |
10256cbe JD |
581 | u->flags.sign = SIGN_SUPPRESS; |
582 | u->flags.decimal = DECIMAL_POINT; | |
583 | u->flags.encoding = ENCODING_DEFAULT; | |
931149a6 | 584 | u->flags.async = ASYNC_NO; |
37b659dd | 585 | u->flags.round = ROUND_UNSPECIFIED; |
931149a6 | 586 | |
6de9cd9a DN |
587 | u->recl = options.default_recl; |
588 | u->endfile = NO_ENDFILE; | |
589 | ||
87557722 | 590 | u->file_len = strlen (stdin_name); |
1a0fd3d3 | 591 | u->file = xmalloc (u->file_len); |
87557722 | 592 | memmove (u->file, stdin_name, u->file_len); |
7812c78c JD |
593 | |
594 | fbuf_init (u, 0); | |
87557722 | 595 | |
5e805e44 | 596 | __gthread_mutex_unlock (&u->lock); |
6de9cd9a DN |
597 | } |
598 | ||
599 | if (options.stdout_unit >= 0) | |
600 | { /* STDOUT */ | |
5e805e44 | 601 | u = insert_unit (options.stdout_unit); |
6de9cd9a DN |
602 | u->s = output_stream (); |
603 | ||
604 | u->flags.action = ACTION_WRITE; | |
605 | ||
606 | u->flags.access = ACCESS_SEQUENTIAL; | |
607 | u->flags.form = FORM_FORMATTED; | |
608 | u->flags.status = STATUS_OLD; | |
ee17607a | 609 | u->flags.blank = BLANK_NULL; |
6de9cd9a | 610 | u->flags.position = POSITION_ASIS; |
10256cbe JD |
611 | u->flags.sign = SIGN_SUPPRESS; |
612 | u->flags.decimal = DECIMAL_POINT; | |
75b2dba9 | 613 | u->flags.delim = DELIM_UNSPECIFIED; |
10256cbe | 614 | u->flags.encoding = ENCODING_DEFAULT; |
931149a6 | 615 | u->flags.async = ASYNC_NO; |
37b659dd | 616 | u->flags.round = ROUND_UNSPECIFIED; |
6de9cd9a DN |
617 | |
618 | u->recl = options.default_recl; | |
fbac3363 | 619 | u->endfile = AT_ENDFILE; |
87557722 JD |
620 | |
621 | u->file_len = strlen (stdout_name); | |
1a0fd3d3 | 622 | u->file = xmalloc (u->file_len); |
87557722 | 623 | memmove (u->file, stdout_name, u->file_len); |
15877a88 JB |
624 | |
625 | fbuf_init (u, 0); | |
fbac3363 | 626 | |
5e805e44 | 627 | __gthread_mutex_unlock (&u->lock); |
fbac3363 DE |
628 | } |
629 | ||
630 | if (options.stderr_unit >= 0) | |
631 | { /* STDERR */ | |
5e805e44 | 632 | u = insert_unit (options.stderr_unit); |
fbac3363 DE |
633 | u->s = error_stream (); |
634 | ||
635 | u->flags.action = ACTION_WRITE; | |
636 | ||
637 | u->flags.access = ACCESS_SEQUENTIAL; | |
638 | u->flags.form = FORM_FORMATTED; | |
639 | u->flags.status = STATUS_OLD; | |
ee17607a | 640 | u->flags.blank = BLANK_NULL; |
fbac3363 | 641 | u->flags.position = POSITION_ASIS; |
10256cbe JD |
642 | u->flags.sign = SIGN_SUPPRESS; |
643 | u->flags.decimal = DECIMAL_POINT; | |
644 | u->flags.encoding = ENCODING_DEFAULT; | |
931149a6 | 645 | u->flags.async = ASYNC_NO; |
37b659dd | 646 | u->flags.round = ROUND_UNSPECIFIED; |
fbac3363 DE |
647 | |
648 | u->recl = options.default_recl; | |
6de9cd9a DN |
649 | u->endfile = AT_ENDFILE; |
650 | ||
87557722 | 651 | u->file_len = strlen (stderr_name); |
1a0fd3d3 | 652 | u->file = xmalloc (u->file_len); |
87557722 | 653 | memmove (u->file, stderr_name, u->file_len); |
15877a88 JB |
654 | |
655 | fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing | |
656 | any kind of exotic formatting to stderr. */ | |
87557722 | 657 | |
5e805e44 | 658 | __gthread_mutex_unlock (&u->lock); |
6de9cd9a DN |
659 | } |
660 | ||
661 | /* Calculate the maximum file offset in a portable manner. | |
dcfddbd4 JD |
662 | max will be the largest signed number for the type gfc_offset. |
663 | set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */ | |
5e805e44 JJ |
664 | max_offset = 0; |
665 | for (i = 0; i < sizeof (max_offset) * 8 - 1; i++) | |
666 | max_offset = max_offset + ((gfc_offset) 1 << i); | |
6de9cd9a DN |
667 | } |
668 | ||
669 | ||
5e805e44 JJ |
670 | static int |
671 | close_unit_1 (gfc_unit *u, int locked) | |
6de9cd9a DN |
672 | { |
673 | int i, rc; | |
15877a88 | 674 | |
13846929 JD |
675 | /* If there are previously written bytes from a write with ADVANCE="no" |
676 | Reposition the buffer before closing. */ | |
108bc190 TK |
677 | if (u->previous_nonadvancing_write) |
678 | finish_last_advance_record (u); | |
13846929 | 679 | |
2ac7316d | 680 | rc = (u->s == NULL) ? 0 : sclose (u->s) == -1; |
5e805e44 JJ |
681 | |
682 | u->closed = 1; | |
683 | if (!locked) | |
684 | __gthread_mutex_lock (&unit_lock); | |
685 | ||
6de9cd9a DN |
686 | for (i = 0; i < CACHE_SIZE; i++) |
687 | if (unit_cache[i] == u) | |
688 | unit_cache[i] = NULL; | |
689 | ||
6de9cd9a | 690 | delete_unit (u); |
5e805e44 | 691 | |
04695783 | 692 | free (u->file); |
5e805e44 JJ |
693 | u->file = NULL; |
694 | u->file_len = 0; | |
7812c78c JD |
695 | |
696 | free_format_hash_table (u); | |
15877a88 | 697 | fbuf_destroy (u); |
5e805e44 JJ |
698 | |
699 | if (!locked) | |
700 | __gthread_mutex_unlock (&u->lock); | |
701 | ||
702 | /* If there are any threads waiting in find_unit for this unit, | |
703 | avoid freeing the memory, the last such thread will free it | |
704 | instead. */ | |
705 | if (u->waiting == 0) | |
ef4195d6 | 706 | destroy_unit_mutex (u); |
5e805e44 JJ |
707 | |
708 | if (!locked) | |
709 | __gthread_mutex_unlock (&unit_lock); | |
6de9cd9a DN |
710 | |
711 | return rc; | |
712 | } | |
713 | ||
5e805e44 JJ |
714 | void |
715 | unlock_unit (gfc_unit *u) | |
716 | { | |
717 | __gthread_mutex_unlock (&u->lock); | |
718 | } | |
719 | ||
720 | /* close_unit()-- Close a unit. The stream is closed, and any memory | |
dcfddbd4 JD |
721 | associated with the stream is freed. Returns nonzero on I/O error. |
722 | Should be called with the u->lock locked. */ | |
5e805e44 JJ |
723 | |
724 | int | |
725 | close_unit (gfc_unit *u) | |
726 | { | |
727 | return close_unit_1 (u, 0); | |
728 | } | |
729 | ||
6de9cd9a DN |
730 | |
731 | /* close_units()-- Delete units on completion. We just keep deleting | |
dcfddbd4 JD |
732 | the root of the treap until there is nothing left. |
733 | Not sure what to do with locking here. Some other thread might be | |
734 | holding some unit's lock and perhaps hold it indefinitely | |
735 | (e.g. waiting for input from some pipe) and close_units shouldn't | |
736 | delay the program too much. */ | |
6de9cd9a DN |
737 | |
738 | void | |
739 | close_units (void) | |
740 | { | |
5e805e44 JJ |
741 | __gthread_mutex_lock (&unit_lock); |
742 | while (unit_root != NULL) | |
743 | close_unit_1 (unit_root, 1); | |
744 | __gthread_mutex_unlock (&unit_lock); | |
6de9cd9a | 745 | } |
16d962d9 JD |
746 | |
747 | ||
7d5ee219 JB |
748 | /* High level interface to truncate a file, i.e. flush format buffers, |
749 | and generate an error or set some flags. Just like POSIX | |
750 | ftruncate, returns 0 on success, -1 on failure. */ | |
7812c78c JD |
751 | |
752 | int | |
753 | unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common) | |
754 | { | |
755 | int ret; | |
756 | ||
757 | /* Make sure format buffer is flushed. */ | |
758 | if (u->flags.form == FORM_FORMATTED) | |
759 | { | |
760 | if (u->mode == READING) | |
761 | pos += fbuf_reset (u); | |
762 | else | |
763 | fbuf_flush (u, u->mode); | |
764 | } | |
765 | ||
7812c78c JD |
766 | /* struncate() should flush the stream buffer if necessary, so don't |
767 | bother calling sflush() here. */ | |
768 | ret = struncate (u->s, pos); | |
769 | ||
770 | if (ret != 0) | |
7d5ee219 | 771 | generate_error (common, LIBERROR_OS, NULL); |
7812c78c JD |
772 | else |
773 | { | |
774 | u->endfile = AT_ENDFILE; | |
775 | u->flags.position = POSITION_APPEND; | |
776 | } | |
777 | ||
778 | return ret; | |
779 | } | |
780 | ||
781 | ||
87557722 JD |
782 | /* filename_from_unit()-- If the unit_number exists, return a pointer to the |
783 | name of the associated file, otherwise return the empty string. The caller | |
784 | must free memory allocated for the filename string. */ | |
785 | ||
786 | char * | |
8eacc23d | 787 | filename_from_unit (int n) |
87557722 | 788 | { |
8eacc23d SK |
789 | gfc_unit *u; |
790 | int c; | |
791 | ||
792 | /* Find the unit. */ | |
793 | u = unit_root; | |
794 | while (u != NULL) | |
795 | { | |
796 | c = compare (n, u->unit_number); | |
797 | if (c < 0) | |
798 | u = u->left; | |
799 | if (c > 0) | |
800 | u = u->right; | |
801 | if (c == 0) | |
802 | break; | |
803 | } | |
804 | ||
805 | /* Get the filename. */ | |
87557722 | 806 | if (u != NULL) |
4269f19c | 807 | return fc_strdup (u->file, u->file_len); |
87557722 JD |
808 | else |
809 | return (char *) NULL; | |
8eacc23d SK |
810 | } |
811 | ||
108bc190 TK |
812 | void |
813 | finish_last_advance_record (gfc_unit *u) | |
814 | { | |
15877a88 | 815 | |
108bc190 | 816 | if (u->saved_pos > 0) |
7812c78c | 817 | fbuf_seek (u, u->saved_pos, SEEK_CUR); |
108bc190 TK |
818 | |
819 | if (!(u->unit_number == options.stdout_unit | |
820 | || u->unit_number == options.stderr_unit)) | |
821 | { | |
108bc190 | 822 | #ifdef HAVE_CRLF |
7812c78c | 823 | const int len = 2; |
108bc190 | 824 | #else |
7812c78c | 825 | const int len = 1; |
108bc190 | 826 | #endif |
7812c78c JD |
827 | char *p = fbuf_alloc (u, len); |
828 | if (!p) | |
108bc190 | 829 | os_error ("Completing record after ADVANCE_NO failed"); |
7812c78c JD |
830 | #ifdef HAVE_CRLF |
831 | *(p++) = '\r'; | |
832 | #endif | |
833 | *p = '\n'; | |
108bc190 | 834 | } |
7812c78c JD |
835 | |
836 | fbuf_flush (u, u->mode); | |
108bc190 TK |
837 | } |
838 | ||
dcfddbd4 JD |
839 | /* Assign a negative number for NEWUNIT in OPEN statements. */ |
840 | GFC_INTEGER_4 | |
841 | get_unique_unit_number (st_parameter_open *opp) | |
842 | { | |
843 | GFC_INTEGER_4 num; | |
844 | ||
ea5e3c04 JB |
845 | #ifdef HAVE_SYNC_FETCH_AND_ADD |
846 | num = __sync_fetch_and_add (&next_available_newunit, -1); | |
847 | #else | |
dcfddbd4 JD |
848 | __gthread_mutex_lock (&unit_lock); |
849 | num = next_available_newunit--; | |
ea5e3c04 JB |
850 | __gthread_mutex_unlock (&unit_lock); |
851 | #endif | |
dcfddbd4 JD |
852 | |
853 | /* Do not allow NEWUNIT numbers to wrap. */ | |
eb6a1e56 | 854 | if (num > GFC_FIRST_NEWUNIT) |
dcfddbd4 | 855 | { |
dcfddbd4 JD |
856 | generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted"); |
857 | return 0; | |
858 | } | |
dcfddbd4 JD |
859 | return num; |
860 | } |