|
145
|
1 /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
|
|
111
|
2 Contributed by Andy Vaught
|
|
|
3 F2003 I/O support contributed by Jerry DeLisle
|
|
|
4
|
|
|
5 This file is part of the GNU Fortran runtime library (libgfortran).
|
|
|
6
|
|
|
7 Libgfortran is free software; you can redistribute it and/or modify
|
|
|
8 it under the terms of the GNU General Public License as published by
|
|
|
9 the Free Software Foundation; either version 3, or (at your option)
|
|
|
10 any later version.
|
|
|
11
|
|
|
12 Libgfortran is distributed in the hope that it will be useful,
|
|
|
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
15 GNU General Public License for more details.
|
|
|
16
|
|
|
17 Under Section 7 of GPL version 3, you are granted additional
|
|
|
18 permissions described in the GCC Runtime Library Exception, version
|
|
|
19 3.1, as published by the Free Software Foundation.
|
|
|
20
|
|
|
21 You should have received a copy of the GNU General Public License and
|
|
|
22 a copy of the GCC Runtime Library Exception along with this program;
|
|
|
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
|
24 <http://www.gnu.org/licenses/>. */
|
|
|
25
|
|
|
26 #include "io.h"
|
|
|
27 #include "fbuf.h"
|
|
|
28 #include "format.h"
|
|
|
29 #include "unix.h"
|
|
131
|
30 #include "async.h"
|
|
111
|
31 #include <string.h>
|
|
|
32 #include <assert.h>
|
|
|
33
|
|
|
34
|
|
|
35 /* IO locking rules:
|
|
|
36 UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
|
|
|
37 Concurrent use of different units should be supported, so
|
|
|
38 each unit has its own lock, LOCK.
|
|
|
39 Open should be atomic with its reopening of units and list_read.c
|
|
|
40 in several places needs find_unit another unit while holding stdin
|
|
|
41 unit's lock, so it must be possible to acquire UNIT_LOCK while holding
|
|
|
42 some unit's lock. Therefore to avoid deadlocks, it is forbidden
|
|
|
43 to acquire unit's private locks while holding UNIT_LOCK, except
|
|
|
44 for freshly created units (where no other thread can get at their
|
|
|
45 address yet) or when using just trylock rather than lock operation.
|
|
|
46 In addition to unit's private lock each unit has a WAITERS counter
|
|
|
47 and CLOSED flag. WAITERS counter must be either only
|
|
|
48 atomically incremented/decremented in all places (if atomic builtins
|
|
|
49 are supported), or protected by UNIT_LOCK in all places (otherwise).
|
|
|
50 CLOSED flag must be always protected by unit's LOCK.
|
|
|
51 After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
|
|
|
52 WAITERS must be incremented to avoid concurrent close from freeing
|
|
|
53 the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
|
|
|
54 Unit freeing is always done under UNIT_LOCK. If close_unit sees any
|
|
|
55 WAITERS, it doesn't free the unit but instead sets the CLOSED flag
|
|
|
56 and the thread that decrements WAITERS to zero while CLOSED flag is
|
|
|
57 set is responsible for freeing it (while holding UNIT_LOCK).
|
|
|
58 flush_all_units operation is iterating over the unit tree with
|
|
|
59 increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
|
|
|
60 flush each unit (and therefore needs the unit's LOCK held as well).
|
|
|
61 To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
|
|
|
62 remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
|
|
|
63 unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
|
|
|
64 the smallest UNIT_NUMBER above the last one flushed.
|
|
|
65
|
|
|
66 If find_unit/find_or_create_unit/find_file/get_unit routines return
|
|
|
67 non-NULL, the returned unit has its private lock locked and when the
|
|
|
68 caller is done with it, it must call either unlock_unit or close_unit
|
|
|
69 on it. unlock_unit or close_unit must be always called only with the
|
|
|
70 private lock held. */
|
|
|
71
|
|
|
72
|
|
|
73
|
|
|
74 /* Table of allocated newunit values. A simple solution would be to
|
|
|
75 map OS file descriptors (fd's) to unit numbers, e.g. with newunit =
|
|
|
76 -fd - 2, however that doesn't work since Fortran allows an existing
|
|
|
77 unit number to be reassociated with a new file. Thus the simple
|
|
|
78 approach may lead to a situation where we'd try to assign a
|
|
|
79 (negative) unit number which already exists. Hence we must keep
|
|
|
80 track of allocated newunit values ourselves. This is the purpose of
|
|
|
81 the newunits array. The indices map to newunit values as newunit =
|
|
|
82 -index + NEWUNIT_FIRST. E.g. newunits[0] having the value true
|
|
|
83 means that a unit with number NEWUNIT_FIRST exists. Similar to
|
|
|
84 POSIX file descriptors, we always allocate the lowest (in absolute
|
|
|
85 value) available unit number.
|
|
|
86 */
|
|
|
87 static bool *newunits;
|
|
|
88 static int newunit_size; /* Total number of elements in the newunits array. */
|
|
|
89 /* Low water indicator for the newunits array. Below the LWI all the
|
|
|
90 units are allocated, above and equal to the LWI there may be both
|
|
|
91 allocated and free units. */
|
|
|
92 static int newunit_lwi;
|
|
|
93
|
|
|
94 /* Unit numbers assigned with NEWUNIT start from here. */
|
|
|
95 #define NEWUNIT_START -10
|
|
|
96
|
|
|
97 #define CACHE_SIZE 3
|
|
|
98 static gfc_unit *unit_cache[CACHE_SIZE];
|
|
131
|
99
|
|
111
|
100 gfc_offset max_offset;
|
|
131
|
101 gfc_offset default_recl;
|
|
|
102
|
|
111
|
103 gfc_unit *unit_root;
|
|
|
104 #ifdef __GTHREAD_MUTEX_INIT
|
|
|
105 __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
|
|
|
106 #else
|
|
|
107 __gthread_mutex_t unit_lock;
|
|
|
108 #endif
|
|
|
109
|
|
|
110 /* We use these filenames for error reporting. */
|
|
|
111
|
|
|
112 static char stdin_name[] = "stdin";
|
|
|
113 static char stdout_name[] = "stdout";
|
|
|
114 static char stderr_name[] = "stderr";
|
|
|
115
|
|
|
116
|
|
|
117 #ifdef HAVE_NEWLOCALE
|
|
|
118 locale_t c_locale;
|
|
|
119 #else
|
|
|
120 /* If we don't have POSIX 2008 per-thread locales, we need to use the
|
|
|
121 traditional setlocale(). To prevent multiple concurrent threads
|
|
|
122 doing formatted I/O from messing up the locale, we need to store a
|
|
|
123 global old_locale, and a counter keeping track of how many threads
|
|
|
124 are currently doing formatted I/O. The first thread saves the old
|
|
|
125 locale, and the last one restores it. */
|
|
|
126 char *old_locale;
|
|
|
127 int old_locale_ctr;
|
|
|
128 #ifdef __GTHREAD_MUTEX_INIT
|
|
|
129 __gthread_mutex_t old_locale_lock = __GTHREAD_MUTEX_INIT;
|
|
|
130 #else
|
|
|
131 __gthread_mutex_t old_locale_lock;
|
|
|
132 #endif
|
|
|
133 #endif
|
|
|
134
|
|
|
135
|
|
|
136 /* This implementation is based on Stefan Nilsson's article in the
|
|
|
137 July 1997 Doctor Dobb's Journal, "Treaps in Java". */
|
|
|
138
|
|
|
139 /* pseudo_random()-- Simple linear congruential pseudorandom number
|
|
|
140 generator. The period of this generator is 44071, which is plenty
|
|
|
141 for our purposes. */
|
|
|
142
|
|
|
143 static int
|
|
|
144 pseudo_random (void)
|
|
|
145 {
|
|
|
146 static int x0 = 5341;
|
|
|
147
|
|
|
148 x0 = (22611 * x0 + 10) % 44071;
|
|
|
149 return x0;
|
|
|
150 }
|
|
|
151
|
|
|
152
|
|
|
153 /* rotate_left()-- Rotate the treap left */
|
|
|
154
|
|
|
155 static gfc_unit *
|
|
|
156 rotate_left (gfc_unit *t)
|
|
|
157 {
|
|
|
158 gfc_unit *temp;
|
|
|
159
|
|
|
160 temp = t->right;
|
|
|
161 t->right = t->right->left;
|
|
|
162 temp->left = t;
|
|
|
163
|
|
|
164 return temp;
|
|
|
165 }
|
|
|
166
|
|
|
167
|
|
|
168 /* rotate_right()-- Rotate the treap right */
|
|
|
169
|
|
|
170 static gfc_unit *
|
|
|
171 rotate_right (gfc_unit *t)
|
|
|
172 {
|
|
|
173 gfc_unit *temp;
|
|
|
174
|
|
|
175 temp = t->left;
|
|
|
176 t->left = t->left->right;
|
|
|
177 temp->right = t;
|
|
|
178
|
|
|
179 return temp;
|
|
|
180 }
|
|
|
181
|
|
|
182
|
|
|
183 static int
|
|
|
184 compare (int a, int b)
|
|
|
185 {
|
|
|
186 if (a < b)
|
|
|
187 return -1;
|
|
|
188 if (a > b)
|
|
|
189 return 1;
|
|
|
190
|
|
|
191 return 0;
|
|
|
192 }
|
|
|
193
|
|
|
194
|
|
|
195 /* insert()-- Recursive insertion function. Returns the updated treap. */
|
|
|
196
|
|
|
197 static gfc_unit *
|
|
|
198 insert (gfc_unit *new, gfc_unit *t)
|
|
|
199 {
|
|
|
200 int c;
|
|
|
201
|
|
|
202 if (t == NULL)
|
|
|
203 return new;
|
|
|
204
|
|
|
205 c = compare (new->unit_number, t->unit_number);
|
|
|
206
|
|
|
207 if (c < 0)
|
|
|
208 {
|
|
|
209 t->left = insert (new, t->left);
|
|
|
210 if (t->priority < t->left->priority)
|
|
|
211 t = rotate_right (t);
|
|
|
212 }
|
|
|
213
|
|
|
214 if (c > 0)
|
|
|
215 {
|
|
|
216 t->right = insert (new, t->right);
|
|
|
217 if (t->priority < t->right->priority)
|
|
|
218 t = rotate_left (t);
|
|
|
219 }
|
|
|
220
|
|
|
221 if (c == 0)
|
|
|
222 internal_error (NULL, "insert(): Duplicate key found!");
|
|
|
223
|
|
|
224 return t;
|
|
|
225 }
|
|
|
226
|
|
|
227
|
|
|
228 /* insert_unit()-- Create a new node, insert it into the treap. */
|
|
|
229
|
|
|
230 static gfc_unit *
|
|
|
231 insert_unit (int n)
|
|
|
232 {
|
|
|
233 gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
|
|
|
234 u->unit_number = n;
|
|
131
|
235 u->internal_unit_kind = 0;
|
|
111
|
236 #ifdef __GTHREAD_MUTEX_INIT
|
|
|
237 {
|
|
|
238 __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
|
|
|
239 u->lock = tmp;
|
|
|
240 }
|
|
|
241 #else
|
|
|
242 __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
|
|
|
243 #endif
|
|
131
|
244 LOCK (&u->lock);
|
|
111
|
245 u->priority = pseudo_random ();
|
|
|
246 unit_root = insert (u, unit_root);
|
|
|
247 return u;
|
|
|
248 }
|
|
|
249
|
|
|
250
|
|
|
251 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
|
|
|
252
|
|
|
253 static void
|
|
|
254 destroy_unit_mutex (gfc_unit *u)
|
|
|
255 {
|
|
|
256 __gthread_mutex_destroy (&u->lock);
|
|
|
257 free (u);
|
|
|
258 }
|
|
|
259
|
|
|
260
|
|
|
261 static gfc_unit *
|
|
|
262 delete_root (gfc_unit *t)
|
|
|
263 {
|
|
|
264 gfc_unit *temp;
|
|
|
265
|
|
|
266 if (t->left == NULL)
|
|
|
267 return t->right;
|
|
|
268 if (t->right == NULL)
|
|
|
269 return t->left;
|
|
|
270
|
|
|
271 if (t->left->priority > t->right->priority)
|
|
|
272 {
|
|
|
273 temp = rotate_right (t);
|
|
|
274 temp->right = delete_root (t);
|
|
|
275 }
|
|
|
276 else
|
|
|
277 {
|
|
|
278 temp = rotate_left (t);
|
|
|
279 temp->left = delete_root (t);
|
|
|
280 }
|
|
|
281
|
|
|
282 return temp;
|
|
|
283 }
|
|
|
284
|
|
|
285
|
|
|
286 /* delete_treap()-- Delete an element from a tree. The 'old' value
|
|
|
287 does not necessarily have to point to the element to be deleted, it
|
|
|
288 must just point to a treap structure with the key to be deleted.
|
|
|
289 Returns the new root node of the tree. */
|
|
|
290
|
|
|
291 static gfc_unit *
|
|
|
292 delete_treap (gfc_unit *old, gfc_unit *t)
|
|
|
293 {
|
|
|
294 int c;
|
|
|
295
|
|
|
296 if (t == NULL)
|
|
|
297 return NULL;
|
|
|
298
|
|
|
299 c = compare (old->unit_number, t->unit_number);
|
|
|
300
|
|
|
301 if (c < 0)
|
|
|
302 t->left = delete_treap (old, t->left);
|
|
|
303 if (c > 0)
|
|
|
304 t->right = delete_treap (old, t->right);
|
|
|
305 if (c == 0)
|
|
|
306 t = delete_root (t);
|
|
|
307
|
|
|
308 return t;
|
|
|
309 }
|
|
|
310
|
|
|
311
|
|
|
312 /* delete_unit()-- Delete a unit from a tree */
|
|
|
313
|
|
|
314 static void
|
|
|
315 delete_unit (gfc_unit *old)
|
|
|
316 {
|
|
|
317 unit_root = delete_treap (old, unit_root);
|
|
|
318 }
|
|
|
319
|
|
|
320
|
|
|
321 /* get_gfc_unit()-- Given an integer, return a pointer to the unit
|
|
|
322 structure. Returns NULL if the unit does not exist,
|
|
|
323 otherwise returns a locked unit. */
|
|
|
324
|
|
|
325 static gfc_unit *
|
|
|
326 get_gfc_unit (int n, int do_create)
|
|
|
327 {
|
|
|
328 gfc_unit *p;
|
|
|
329 int c, created = 0;
|
|
|
330
|
|
131
|
331 NOTE ("Unit n=%d, do_create = %d", n, do_create);
|
|
|
332 LOCK (&unit_lock);
|
|
|
333
|
|
111
|
334 retry:
|
|
|
335 for (c = 0; c < CACHE_SIZE; c++)
|
|
|
336 if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
|
|
|
337 {
|
|
|
338 p = unit_cache[c];
|
|
|
339 goto found;
|
|
|
340 }
|
|
|
341
|
|
|
342 p = unit_root;
|
|
|
343 while (p != NULL)
|
|
|
344 {
|
|
|
345 c = compare (n, p->unit_number);
|
|
|
346 if (c < 0)
|
|
|
347 p = p->left;
|
|
|
348 if (c > 0)
|
|
|
349 p = p->right;
|
|
|
350 if (c == 0)
|
|
|
351 break;
|
|
|
352 }
|
|
|
353
|
|
|
354 if (p == NULL && do_create)
|
|
|
355 {
|
|
|
356 p = insert_unit (n);
|
|
|
357 created = 1;
|
|
|
358 }
|
|
|
359
|
|
|
360 if (p != NULL)
|
|
|
361 {
|
|
|
362 for (c = 0; c < CACHE_SIZE - 1; c++)
|
|
|
363 unit_cache[c] = unit_cache[c + 1];
|
|
|
364
|
|
|
365 unit_cache[CACHE_SIZE - 1] = p;
|
|
|
366 }
|
|
|
367
|
|
|
368 if (created)
|
|
|
369 {
|
|
|
370 /* Newly created units have their lock held already
|
|
|
371 from insert_unit. Just unlock UNIT_LOCK and return. */
|
|
131
|
372 UNLOCK (&unit_lock);
|
|
111
|
373 return p;
|
|
|
374 }
|
|
|
375
|
|
|
376 found:
|
|
|
377 if (p != NULL && (p->child_dtio == 0))
|
|
|
378 {
|
|
|
379 /* Fast path. */
|
|
131
|
380 if (! TRYLOCK (&p->lock))
|
|
111
|
381 {
|
|
|
382 /* assert (p->closed == 0); */
|
|
131
|
383 UNLOCK (&unit_lock);
|
|
111
|
384 return p;
|
|
|
385 }
|
|
|
386
|
|
|
387 inc_waiting_locked (p);
|
|
|
388 }
|
|
|
389
|
|
|
390
|
|
131
|
391 UNLOCK (&unit_lock);
|
|
111
|
392
|
|
|
393 if (p != NULL && (p->child_dtio == 0))
|
|
|
394 {
|
|
131
|
395 LOCK (&p->lock);
|
|
111
|
396 if (p->closed)
|
|
|
397 {
|
|
131
|
398 LOCK (&unit_lock);
|
|
|
399 UNLOCK (&p->lock);
|
|
111
|
400 if (predec_waiting_locked (p) == 0)
|
|
|
401 destroy_unit_mutex (p);
|
|
|
402 goto retry;
|
|
|
403 }
|
|
|
404
|
|
|
405 dec_waiting_unlocked (p);
|
|
|
406 }
|
|
|
407 return p;
|
|
|
408 }
|
|
|
409
|
|
|
410
|
|
|
411 gfc_unit *
|
|
|
412 find_unit (int n)
|
|
|
413 {
|
|
|
414 return get_gfc_unit (n, 0);
|
|
|
415 }
|
|
|
416
|
|
|
417
|
|
|
418 gfc_unit *
|
|
|
419 find_or_create_unit (int n)
|
|
|
420 {
|
|
|
421 return get_gfc_unit (n, 1);
|
|
|
422 }
|
|
|
423
|
|
|
424
|
|
|
425 /* Helper function to check rank, stride, format string, and namelist.
|
|
|
426 This is used for optimization. You can't trim out blanks or shorten
|
|
|
427 the string if trailing spaces are significant. */
|
|
|
428 static bool
|
|
|
429 is_trim_ok (st_parameter_dt *dtp)
|
|
|
430 {
|
|
|
431 /* Check rank and stride. */
|
|
|
432 if (dtp->internal_unit_desc)
|
|
|
433 return false;
|
|
145
|
434 /* Format strings cannot have 'BZ' or '/'. */
|
|
111
|
435 if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
|
|
|
436 {
|
|
|
437 char *p = dtp->format;
|
|
|
438 if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
|
|
|
439 return false;
|
|
131
|
440 for (gfc_charlen_type i = 0; i < dtp->format_len; i++)
|
|
111
|
441 {
|
|
|
442 if (p[i] == '/') return false;
|
|
|
443 if (p[i] == 'b' || p[i] == 'B')
|
|
|
444 if (p[i+1] == 'z' || p[i+1] == 'Z')
|
|
|
445 return false;
|
|
|
446 }
|
|
|
447 }
|
|
|
448 if (dtp->u.p.ionml) /* A namelist. */
|
|
|
449 return false;
|
|
|
450 return true;
|
|
|
451 }
|
|
|
452
|
|
|
453
|
|
|
454 gfc_unit *
|
|
|
455 set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
|
|
|
456 {
|
|
|
457 gfc_offset start_record = 0;
|
|
|
458
|
|
|
459 iunit->unit_number = dtp->common.unit;
|
|
|
460 iunit->recl = dtp->internal_unit_len;
|
|
|
461 iunit->internal_unit = dtp->internal_unit;
|
|
|
462 iunit->internal_unit_len = dtp->internal_unit_len;
|
|
|
463 iunit->internal_unit_kind = kind;
|
|
|
464
|
|
|
465 /* As an optimization, adjust the unit record length to not
|
|
|
466 include trailing blanks. This will not work under certain conditions
|
|
|
467 where trailing blanks have significance. */
|
|
|
468 if (dtp->u.p.mode == READING && is_trim_ok (dtp))
|
|
|
469 {
|
|
|
470 int len;
|
|
|
471 if (kind == 1)
|
|
|
472 len = string_len_trim (iunit->internal_unit_len,
|
|
|
473 iunit->internal_unit);
|
|
|
474 else
|
|
|
475 len = string_len_trim_char4 (iunit->internal_unit_len,
|
|
|
476 (const gfc_char4_t*) iunit->internal_unit);
|
|
|
477 iunit->internal_unit_len = len;
|
|
|
478 iunit->recl = iunit->internal_unit_len;
|
|
|
479 }
|
|
|
480
|
|
|
481 /* Set up the looping specification from the array descriptor, if any. */
|
|
|
482
|
|
|
483 if (is_array_io (dtp))
|
|
|
484 {
|
|
|
485 iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
|
|
|
486 iunit->ls = (array_loop_spec *)
|
|
|
487 xmallocarray (iunit->rank, sizeof (array_loop_spec));
|
|
|
488 iunit->internal_unit_len *=
|
|
|
489 init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
|
|
|
490
|
|
|
491 start_record *= iunit->recl;
|
|
|
492 }
|
|
|
493
|
|
|
494 /* Set initial values for unit parameters. */
|
|
|
495 if (kind == 4)
|
|
|
496 iunit->s = open_internal4 (iunit->internal_unit - start_record,
|
|
|
497 iunit->internal_unit_len, -start_record);
|
|
|
498 else
|
|
|
499 iunit->s = open_internal (iunit->internal_unit - start_record,
|
|
|
500 iunit->internal_unit_len, -start_record);
|
|
|
501
|
|
|
502 iunit->bytes_left = iunit->recl;
|
|
|
503 iunit->last_record=0;
|
|
|
504 iunit->maxrec=0;
|
|
|
505 iunit->current_record=0;
|
|
|
506 iunit->read_bad = 0;
|
|
|
507 iunit->endfile = NO_ENDFILE;
|
|
|
508
|
|
|
509 /* Set flags for the internal unit. */
|
|
|
510
|
|
|
511 iunit->flags.access = ACCESS_SEQUENTIAL;
|
|
|
512 iunit->flags.action = ACTION_READWRITE;
|
|
|
513 iunit->flags.blank = BLANK_NULL;
|
|
|
514 iunit->flags.form = FORM_FORMATTED;
|
|
|
515 iunit->flags.pad = PAD_YES;
|
|
|
516 iunit->flags.status = STATUS_UNSPECIFIED;
|
|
145
|
517 iunit->flags.sign = SIGN_PROCDEFINED;
|
|
111
|
518 iunit->flags.decimal = DECIMAL_POINT;
|
|
|
519 iunit->flags.delim = DELIM_UNSPECIFIED;
|
|
|
520 iunit->flags.encoding = ENCODING_DEFAULT;
|
|
|
521 iunit->flags.async = ASYNC_NO;
|
|
145
|
522 iunit->flags.round = ROUND_PROCDEFINED;
|
|
111
|
523
|
|
|
524 /* Initialize the data transfer parameters. */
|
|
|
525
|
|
|
526 dtp->u.p.advance_status = ADVANCE_YES;
|
|
|
527 dtp->u.p.seen_dollar = 0;
|
|
|
528 dtp->u.p.skips = 0;
|
|
|
529 dtp->u.p.pending_spaces = 0;
|
|
|
530 dtp->u.p.max_pos = 0;
|
|
|
531 dtp->u.p.at_eof = 0;
|
|
|
532 return iunit;
|
|
|
533 }
|
|
|
534
|
|
|
535
|
|
|
536 /* get_unit()-- Returns the unit structure associated with the integer
|
|
|
537 unit or the internal file. */
|
|
|
538
|
|
|
539 gfc_unit *
|
|
|
540 get_unit (st_parameter_dt *dtp, int do_create)
|
|
|
541 {
|
|
|
542 gfc_unit *unit;
|
|
|
543
|
|
|
544 if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
|
|
|
545 {
|
|
|
546 int kind;
|
|
|
547 if (dtp->common.unit == GFC_INTERNAL_UNIT)
|
|
|
548 kind = 1;
|
|
|
549 else if (dtp->common.unit == GFC_INTERNAL_UNIT4)
|
|
|
550 kind = 4;
|
|
|
551 else
|
|
|
552 internal_error (&dtp->common, "get_unit(): Bad internal unit KIND");
|
|
|
553
|
|
|
554 dtp->u.p.unit_is_internal = 1;
|
|
|
555 dtp->common.unit = newunit_alloc ();
|
|
|
556 unit = get_gfc_unit (dtp->common.unit, do_create);
|
|
|
557 set_internal_unit (dtp, unit, kind);
|
|
|
558 fbuf_init (unit, 128);
|
|
|
559 return unit;
|
|
|
560 }
|
|
|
561
|
|
|
562 /* Has to be an external unit. */
|
|
|
563 dtp->u.p.unit_is_internal = 0;
|
|
|
564 dtp->internal_unit = NULL;
|
|
|
565 dtp->internal_unit_desc = NULL;
|
|
|
566
|
|
|
567 /* For an external unit with unit number < 0 creating it on the fly
|
|
|
568 is not allowed, such units must be created with
|
|
|
569 OPEN(NEWUNIT=...). */
|
|
|
570 if (dtp->common.unit < 0)
|
|
131
|
571 {
|
|
|
572 if (dtp->common.unit > NEWUNIT_START) /* Reserved units. */
|
|
|
573 return NULL;
|
|
|
574 return get_gfc_unit (dtp->common.unit, 0);
|
|
|
575 }
|
|
111
|
576
|
|
|
577 return get_gfc_unit (dtp->common.unit, do_create);
|
|
|
578 }
|
|
|
579
|
|
|
580
|
|
|
581 /*************************/
|
|
|
582 /* Initialize everything. */
|
|
|
583
|
|
|
584 void
|
|
|
585 init_units (void)
|
|
|
586 {
|
|
|
587 gfc_unit *u;
|
|
|
588
|
|
|
589 #ifdef HAVE_NEWLOCALE
|
|
|
590 c_locale = newlocale (0, "C", 0);
|
|
|
591 #else
|
|
|
592 #ifndef __GTHREAD_MUTEX_INIT
|
|
|
593 __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
|
|
|
594 #endif
|
|
|
595 #endif
|
|
|
596
|
|
|
597 #ifndef __GTHREAD_MUTEX_INIT
|
|
|
598 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
|
|
|
599 #endif
|
|
|
600
|
|
131
|
601 if (sizeof (max_offset) == 8)
|
|
|
602 {
|
|
|
603 max_offset = GFC_INTEGER_8_HUGE;
|
|
|
604 /* Why this weird value? Because if the recl specifier in the
|
|
|
605 inquire statement is a 4 byte value, u->recl is truncated,
|
|
|
606 and this trick ensures it becomes HUGE(0) rather than -1.
|
|
|
607 The full 8 byte value of default_recl is still 0.99999999 *
|
|
|
608 max_offset which is large enough for all practical
|
|
|
609 purposes. */
|
|
|
610 default_recl = max_offset & ~(1LL<<31);
|
|
|
611 }
|
|
|
612 else if (sizeof (max_offset) == 4)
|
|
|
613 max_offset = default_recl = GFC_INTEGER_4_HUGE;
|
|
|
614 else
|
|
|
615 internal_error (NULL, "sizeof (max_offset) must be 4 or 8");
|
|
|
616
|
|
111
|
617 if (options.stdin_unit >= 0)
|
|
|
618 { /* STDIN */
|
|
|
619 u = insert_unit (options.stdin_unit);
|
|
|
620 u->s = input_stream ();
|
|
|
621
|
|
|
622 u->flags.action = ACTION_READ;
|
|
|
623
|
|
|
624 u->flags.access = ACCESS_SEQUENTIAL;
|
|
|
625 u->flags.form = FORM_FORMATTED;
|
|
|
626 u->flags.status = STATUS_OLD;
|
|
|
627 u->flags.blank = BLANK_NULL;
|
|
|
628 u->flags.pad = PAD_YES;
|
|
|
629 u->flags.position = POSITION_ASIS;
|
|
145
|
630 u->flags.sign = SIGN_PROCDEFINED;
|
|
111
|
631 u->flags.decimal = DECIMAL_POINT;
|
|
|
632 u->flags.delim = DELIM_UNSPECIFIED;
|
|
|
633 u->flags.encoding = ENCODING_DEFAULT;
|
|
|
634 u->flags.async = ASYNC_NO;
|
|
145
|
635 u->flags.round = ROUND_PROCDEFINED;
|
|
111
|
636 u->flags.share = SHARE_UNSPECIFIED;
|
|
|
637 u->flags.cc = CC_LIST;
|
|
|
638
|
|
131
|
639 u->recl = default_recl;
|
|
111
|
640 u->endfile = NO_ENDFILE;
|
|
|
641
|
|
|
642 u->filename = strdup (stdin_name);
|
|
|
643
|
|
|
644 fbuf_init (u, 0);
|
|
|
645
|
|
131
|
646 UNLOCK (&u->lock);
|
|
111
|
647 }
|
|
|
648
|
|
|
649 if (options.stdout_unit >= 0)
|
|
|
650 { /* STDOUT */
|
|
|
651 u = insert_unit (options.stdout_unit);
|
|
|
652 u->s = output_stream ();
|
|
|
653
|
|
|
654 u->flags.action = ACTION_WRITE;
|
|
|
655
|
|
|
656 u->flags.access = ACCESS_SEQUENTIAL;
|
|
|
657 u->flags.form = FORM_FORMATTED;
|
|
|
658 u->flags.status = STATUS_OLD;
|
|
|
659 u->flags.blank = BLANK_NULL;
|
|
|
660 u->flags.position = POSITION_ASIS;
|
|
145
|
661 u->flags.sign = SIGN_PROCDEFINED;
|
|
111
|
662 u->flags.decimal = DECIMAL_POINT;
|
|
|
663 u->flags.delim = DELIM_UNSPECIFIED;
|
|
|
664 u->flags.encoding = ENCODING_DEFAULT;
|
|
|
665 u->flags.async = ASYNC_NO;
|
|
145
|
666 u->flags.round = ROUND_PROCDEFINED;
|
|
111
|
667 u->flags.share = SHARE_UNSPECIFIED;
|
|
|
668 u->flags.cc = CC_LIST;
|
|
|
669
|
|
131
|
670 u->recl = default_recl;
|
|
111
|
671 u->endfile = AT_ENDFILE;
|
|
|
672
|
|
|
673 u->filename = strdup (stdout_name);
|
|
|
674
|
|
|
675 fbuf_init (u, 0);
|
|
|
676
|
|
131
|
677 UNLOCK (&u->lock);
|
|
111
|
678 }
|
|
|
679
|
|
|
680 if (options.stderr_unit >= 0)
|
|
|
681 { /* STDERR */
|
|
|
682 u = insert_unit (options.stderr_unit);
|
|
|
683 u->s = error_stream ();
|
|
|
684
|
|
|
685 u->flags.action = ACTION_WRITE;
|
|
|
686
|
|
|
687 u->flags.access = ACCESS_SEQUENTIAL;
|
|
|
688 u->flags.form = FORM_FORMATTED;
|
|
|
689 u->flags.status = STATUS_OLD;
|
|
|
690 u->flags.blank = BLANK_NULL;
|
|
|
691 u->flags.position = POSITION_ASIS;
|
|
145
|
692 u->flags.sign = SIGN_PROCDEFINED;
|
|
111
|
693 u->flags.decimal = DECIMAL_POINT;
|
|
|
694 u->flags.encoding = ENCODING_DEFAULT;
|
|
|
695 u->flags.async = ASYNC_NO;
|
|
145
|
696 u->flags.round = ROUND_PROCDEFINED;
|
|
111
|
697 u->flags.share = SHARE_UNSPECIFIED;
|
|
|
698 u->flags.cc = CC_LIST;
|
|
|
699
|
|
131
|
700 u->recl = default_recl;
|
|
111
|
701 u->endfile = AT_ENDFILE;
|
|
|
702
|
|
|
703 u->filename = strdup (stderr_name);
|
|
|
704
|
|
|
705 fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
|
|
|
706 any kind of exotic formatting to stderr. */
|
|
|
707
|
|
131
|
708 UNLOCK (&u->lock);
|
|
111
|
709 }
|
|
131
|
710 /* The default internal units. */
|
|
|
711 u = insert_unit (GFC_INTERNAL_UNIT);
|
|
|
712 UNLOCK (&u->lock);
|
|
|
713 u = insert_unit (GFC_INTERNAL_UNIT4);
|
|
|
714 UNLOCK (&u->lock);
|
|
111
|
715 }
|
|
|
716
|
|
|
717
|
|
|
718 static int
|
|
|
719 close_unit_1 (gfc_unit *u, int locked)
|
|
|
720 {
|
|
|
721 int i, rc;
|
|
|
722
|
|
131
|
723 if (ASYNC_IO && u->au)
|
|
|
724 async_close (u->au);
|
|
|
725
|
|
111
|
726 /* If there are previously written bytes from a write with ADVANCE="no"
|
|
|
727 Reposition the buffer before closing. */
|
|
|
728 if (u->previous_nonadvancing_write)
|
|
|
729 finish_last_advance_record (u);
|
|
|
730
|
|
|
731 rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
|
|
|
732
|
|
|
733 u->closed = 1;
|
|
|
734 if (!locked)
|
|
131
|
735 LOCK (&unit_lock);
|
|
111
|
736
|
|
|
737 for (i = 0; i < CACHE_SIZE; i++)
|
|
|
738 if (unit_cache[i] == u)
|
|
|
739 unit_cache[i] = NULL;
|
|
|
740
|
|
|
741 delete_unit (u);
|
|
|
742
|
|
|
743 free (u->filename);
|
|
|
744 u->filename = NULL;
|
|
|
745
|
|
|
746 free_format_hash_table (u);
|
|
|
747 fbuf_destroy (u);
|
|
|
748
|
|
|
749 if (u->unit_number <= NEWUNIT_START)
|
|
|
750 newunit_free (u->unit_number);
|
|
|
751
|
|
|
752 if (!locked)
|
|
131
|
753 UNLOCK (&u->lock);
|
|
111
|
754
|
|
|
755 /* If there are any threads waiting in find_unit for this unit,
|
|
|
756 avoid freeing the memory, the last such thread will free it
|
|
|
757 instead. */
|
|
|
758 if (u->waiting == 0)
|
|
|
759 destroy_unit_mutex (u);
|
|
|
760
|
|
|
761 if (!locked)
|
|
131
|
762 UNLOCK (&unit_lock);
|
|
111
|
763
|
|
|
764 return rc;
|
|
|
765 }
|
|
|
766
|
|
|
767 void
|
|
|
768 unlock_unit (gfc_unit *u)
|
|
|
769 {
|
|
131
|
770 NOTE ("unlock_unit = %d", u->unit_number);
|
|
|
771 UNLOCK (&u->lock);
|
|
|
772 NOTE ("unlock_unit done");
|
|
111
|
773 }
|
|
|
774
|
|
|
775 /* close_unit()-- Close a unit. The stream is closed, and any memory
|
|
|
776 associated with the stream is freed. Returns nonzero on I/O error.
|
|
|
777 Should be called with the u->lock locked. */
|
|
|
778
|
|
|
779 int
|
|
|
780 close_unit (gfc_unit *u)
|
|
|
781 {
|
|
|
782 return close_unit_1 (u, 0);
|
|
|
783 }
|
|
|
784
|
|
|
785
|
|
|
786 /* close_units()-- Delete units on completion. We just keep deleting
|
|
|
787 the root of the treap until there is nothing left.
|
|
|
788 Not sure what to do with locking here. Some other thread might be
|
|
|
789 holding some unit's lock and perhaps hold it indefinitely
|
|
|
790 (e.g. waiting for input from some pipe) and close_units shouldn't
|
|
|
791 delay the program too much. */
|
|
|
792
|
|
|
793 void
|
|
|
794 close_units (void)
|
|
|
795 {
|
|
131
|
796 LOCK (&unit_lock);
|
|
111
|
797 while (unit_root != NULL)
|
|
|
798 close_unit_1 (unit_root, 1);
|
|
131
|
799 UNLOCK (&unit_lock);
|
|
111
|
800
|
|
|
801 free (newunits);
|
|
|
802
|
|
|
803 #ifdef HAVE_FREELOCALE
|
|
|
804 freelocale (c_locale);
|
|
|
805 #endif
|
|
|
806 }
|
|
|
807
|
|
|
808
|
|
|
809 /* High level interface to truncate a file, i.e. flush format buffers,
|
|
|
810 and generate an error or set some flags. Just like POSIX
|
|
|
811 ftruncate, returns 0 on success, -1 on failure. */
|
|
|
812
|
|
|
813 int
|
|
|
814 unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
|
|
|
815 {
|
|
|
816 int ret;
|
|
|
817
|
|
|
818 /* Make sure format buffer is flushed. */
|
|
|
819 if (u->flags.form == FORM_FORMATTED)
|
|
|
820 {
|
|
|
821 if (u->mode == READING)
|
|
|
822 pos += fbuf_reset (u);
|
|
|
823 else
|
|
|
824 fbuf_flush (u, u->mode);
|
|
|
825 }
|
|
|
826
|
|
|
827 /* struncate() should flush the stream buffer if necessary, so don't
|
|
|
828 bother calling sflush() here. */
|
|
|
829 ret = struncate (u->s, pos);
|
|
|
830
|
|
|
831 if (ret != 0)
|
|
|
832 generate_error (common, LIBERROR_OS, NULL);
|
|
|
833 else
|
|
|
834 {
|
|
|
835 u->endfile = AT_ENDFILE;
|
|
|
836 u->flags.position = POSITION_APPEND;
|
|
|
837 }
|
|
|
838
|
|
|
839 return ret;
|
|
|
840 }
|
|
|
841
|
|
|
842
|
|
|
843 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
|
|
|
844 name of the associated file, otherwise return the empty string. The caller
|
|
|
845 must free memory allocated for the filename string. */
|
|
|
846
|
|
|
847 char *
|
|
|
848 filename_from_unit (int n)
|
|
|
849 {
|
|
|
850 gfc_unit *u;
|
|
|
851 int c;
|
|
|
852
|
|
|
853 /* Find the unit. */
|
|
|
854 u = unit_root;
|
|
|
855 while (u != NULL)
|
|
|
856 {
|
|
|
857 c = compare (n, u->unit_number);
|
|
|
858 if (c < 0)
|
|
|
859 u = u->left;
|
|
|
860 if (c > 0)
|
|
|
861 u = u->right;
|
|
|
862 if (c == 0)
|
|
|
863 break;
|
|
|
864 }
|
|
|
865
|
|
|
866 /* Get the filename. */
|
|
|
867 if (u != NULL && u->filename != NULL)
|
|
|
868 return strdup (u->filename);
|
|
|
869 else
|
|
|
870 return (char *) NULL;
|
|
|
871 }
|
|
|
872
|
|
|
873 void
|
|
|
874 finish_last_advance_record (gfc_unit *u)
|
|
|
875 {
|
|
|
876
|
|
|
877 if (u->saved_pos > 0)
|
|
|
878 fbuf_seek (u, u->saved_pos, SEEK_CUR);
|
|
|
879
|
|
|
880 if (!(u->unit_number == options.stdout_unit
|
|
|
881 || u->unit_number == options.stderr_unit))
|
|
|
882 {
|
|
|
883 #ifdef HAVE_CRLF
|
|
|
884 const int len = 2;
|
|
|
885 #else
|
|
|
886 const int len = 1;
|
|
|
887 #endif
|
|
|
888 char *p = fbuf_alloc (u, len);
|
|
|
889 if (!p)
|
|
|
890 os_error ("Completing record after ADVANCE_NO failed");
|
|
|
891 #ifdef HAVE_CRLF
|
|
|
892 *(p++) = '\r';
|
|
|
893 #endif
|
|
|
894 *p = '\n';
|
|
|
895 }
|
|
|
896
|
|
|
897 fbuf_flush (u, u->mode);
|
|
|
898 }
|
|
|
899
|
|
|
900
|
|
|
901 /* Assign a negative number for NEWUNIT in OPEN statements or for
|
|
|
902 internal units. */
|
|
|
903 int
|
|
|
904 newunit_alloc (void)
|
|
|
905 {
|
|
131
|
906 LOCK (&unit_lock);
|
|
111
|
907 if (!newunits)
|
|
|
908 {
|
|
|
909 newunits = xcalloc (16, 1);
|
|
|
910 newunit_size = 16;
|
|
|
911 }
|
|
|
912
|
|
|
913 /* Search for the next available newunit. */
|
|
|
914 for (int ii = newunit_lwi; ii < newunit_size; ii++)
|
|
|
915 {
|
|
|
916 if (!newunits[ii])
|
|
|
917 {
|
|
|
918 newunits[ii] = true;
|
|
|
919 newunit_lwi = ii + 1;
|
|
131
|
920 UNLOCK (&unit_lock);
|
|
111
|
921 return -ii + NEWUNIT_START;
|
|
|
922 }
|
|
|
923 }
|
|
|
924
|
|
|
925 /* Search failed, bump size of array and allocate the first
|
|
|
926 available unit. */
|
|
|
927 int old_size = newunit_size;
|
|
|
928 newunit_size *= 2;
|
|
|
929 newunits = xrealloc (newunits, newunit_size);
|
|
|
930 memset (newunits + old_size, 0, old_size);
|
|
|
931 newunits[old_size] = true;
|
|
|
932 newunit_lwi = old_size + 1;
|
|
131
|
933 UNLOCK (&unit_lock);
|
|
111
|
934 return -old_size + NEWUNIT_START;
|
|
|
935 }
|
|
|
936
|
|
|
937
|
|
|
938 /* Free a previously allocated newunit= unit number. unit_lock must
|
|
|
939 be held when calling. */
|
|
|
940
|
|
131
|
941 void
|
|
111
|
942 newunit_free (int unit)
|
|
|
943 {
|
|
|
944 int ind = -unit + NEWUNIT_START;
|
|
|
945 assert(ind >= 0 && ind < newunit_size);
|
|
|
946 newunits[ind] = false;
|
|
|
947 if (ind < newunit_lwi)
|
|
|
948 newunit_lwi = ind;
|
|
|
949 }
|
