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