1 /* Copyright (C) 2002-2014 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 <stdlib.h>
31 #include <string.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 /* Subroutines related to units */
72
73 /* Unit number to be assigned when NEWUNIT is used in an OPEN statement. */
74 #define GFC_FIRST_NEWUNIT -10
75 static GFC_INTEGER_4 next_available_newunit = GFC_FIRST_NEWUNIT;
76
77 #define CACHE_SIZE 3
78 static gfc_unit *unit_cache[CACHE_SIZE];
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
86
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
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
pseudo_random(void)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
112 static gfc_unit *
rotate_left(gfc_unit * t)113 rotate_left (gfc_unit * t)
114 {
115 gfc_unit *temp;
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
127 static gfc_unit *
rotate_right(gfc_unit * t)128 rotate_right (gfc_unit * t)
129 {
130 gfc_unit *temp;
131
132 temp = t->left;
133 t->left = t->left->right;
134 temp->right = t;
135
136 return temp;
137 }
138
139
140 static int
compare(int a,int b)141 compare (int a, int b)
142 {
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
154 static gfc_unit *
insert(gfc_unit * new,gfc_unit * t)155 insert (gfc_unit *new, gfc_unit *t)
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)
179 internal_error (NULL, "insert(): Duplicate key found!");
180
181 return t;
182 }
183
184
185 /* insert_unit()-- Create a new node, insert it into the treap. */
186
187 static gfc_unit *
insert_unit(int n)188 insert_unit (int n)
189 {
190 gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
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;
204 }
205
206
207 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
208
209 static void
destroy_unit_mutex(gfc_unit * u)210 destroy_unit_mutex (gfc_unit * u)
211 {
212 __gthread_mutex_destroy (&u->lock);
213 free (u);
214 }
215
216
217 static gfc_unit *
delete_root(gfc_unit * t)218 delete_root (gfc_unit * t)
219 {
220 gfc_unit *temp;
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
247 static gfc_unit *
delete_treap(gfc_unit * old,gfc_unit * t)248 delete_treap (gfc_unit * old, gfc_unit * t)
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
delete_unit(gfc_unit * old)271 delete_unit (gfc_unit * old)
272 {
273 unit_root = delete_treap (old, unit_root);
274 }
275
276
277 /* get_external_unit()-- Given an integer, return a pointer to the unit
278 * structure. Returns NULL if the unit does not exist,
279 * otherwise returns a locked unit. */
280
281 static gfc_unit *
get_external_unit(int n,int do_create)282 get_external_unit (int n, int do_create)
283 {
284 gfc_unit *p;
285 int c, created = 0;
286
287 __gthread_mutex_lock (&unit_lock);
288 retry:
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];
293 goto found;
294 }
295
296 p = unit_root;
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
308 if (p == NULL && do_create)
309 {
310 p = insert_unit (n);
311 created = 1;
312 }
313
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
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)
354 destroy_unit_mutex (p);
355 goto retry;
356 }
357
358 dec_waiting_unlocked (p);
359 }
360 return p;
361 }
362
363
364 gfc_unit *
find_unit(int n)365 find_unit (int n)
366 {
367 return get_external_unit (n, 0);
368 }
369
370
371 gfc_unit *
find_or_create_unit(int n)372 find_or_create_unit (int n)
373 {
374 return get_external_unit (n, 1);
375 }
376
377
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
is_trim_ok(st_parameter_dt * dtp)382 is_trim_ok (st_parameter_dt *dtp)
383 {
384 /* Check rank and stride. */
385 if (dtp->internal_unit_desc)
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
408 gfc_unit *
get_internal_unit(st_parameter_dt * dtp)409 get_internal_unit (st_parameter_dt *dtp)
410 {
411 gfc_unit * iunit;
412 gfc_offset start_record = 0;
413
414 /* Allocate memory for a unit structure. */
415
416 iunit = xcalloc (1, sizeof (gfc_unit));
417
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);
427
428 iunit->recl = dtp->internal_unit_len;
429
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;
434
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
451 /* Set up the looping specification from the array descriptor, if any. */
452
453 if (is_array_io (dtp))
454 {
455 iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
456 iunit->ls = (array_loop_spec *)
457 xmallocarray (iunit->rank, sizeof (array_loop_spec));
458 dtp->internal_unit_len *=
459 init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
460
461 start_record *= iunit->recl;
462 }
463
464 /* Set initial values for unit parameters. */
465 if (dtp->common.unit)
466 {
467 iunit->s = open_internal4 (dtp->internal_unit - start_record,
468 dtp->internal_unit_len, -start_record);
469 fbuf_init (iunit, 256);
470 }
471 else
472 iunit->s = open_internal (dtp->internal_unit - start_record,
473 dtp->internal_unit_len, -start_record);
474
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;
480 iunit->endfile = NO_ENDFILE;
481
482 /* Set flags for the internal unit. */
483
484 iunit->flags.access = ACCESS_SEQUENTIAL;
485 iunit->flags.action = ACTION_READWRITE;
486 iunit->flags.blank = BLANK_NULL;
487 iunit->flags.form = FORM_FORMATTED;
488 iunit->flags.pad = PAD_YES;
489 iunit->flags.status = STATUS_UNSPECIFIED;
490 iunit->flags.sign = SIGN_SUPPRESS;
491 iunit->flags.decimal = DECIMAL_POINT;
492 iunit->flags.delim = DELIM_UNSPECIFIED;
493 iunit->flags.encoding = ENCODING_DEFAULT;
494 iunit->flags.async = ASYNC_NO;
495 iunit->flags.round = ROUND_UNSPECIFIED;
496
497 /* Initialize the data transfer parameters. */
498
499 dtp->u.p.advance_status = ADVANCE_YES;
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;
504 dtp->u.p.at_eof = 0;
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
514 /* free_internal_unit()-- Free memory allocated for internal units if any. */
515 void
free_internal_unit(st_parameter_dt * dtp)516 free_internal_unit (st_parameter_dt *dtp)
517 {
518 if (!is_internal_unit (dtp))
519 return;
520
521 if (unlikely (is_char4_unit (dtp)))
522 fbuf_destroy (dtp->u.p.current_unit);
523
524 if (dtp->u.p.current_unit != NULL)
525 {
526 free (dtp->u.p.current_unit->ls);
527
528 free (dtp->u.p.current_unit->s);
529
530 destroy_unit_mutex (dtp->u.p.current_unit);
531 }
532 }
533
534
535
536 /* get_unit()-- Returns the unit structure associated with the integer
537 unit or the internal file. */
538
539 gfc_unit *
get_unit(st_parameter_dt * dtp,int do_create)540 get_unit (st_parameter_dt *dtp, int do_create)
541 {
542
543 if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
544 return get_internal_unit (dtp);
545
546 /* Has to be an external unit. */
547
548 dtp->u.p.unit_is_internal = 0;
549 dtp->internal_unit_desc = NULL;
550
551 return get_external_unit (dtp->common.unit, do_create);
552 }
553
554
555 /*************************/
556 /* Initialize everything. */
557
558 void
init_units(void)559 init_units (void)
560 {
561 gfc_unit *u;
562 unsigned int i;
563
564 #ifndef __GTHREAD_MUTEX_INIT
565 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
566 #endif
567
568 if (options.stdin_unit >= 0)
569 { /* STDIN */
570 u = insert_unit (options.stdin_unit);
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;
578 u->flags.blank = BLANK_NULL;
579 u->flags.pad = PAD_YES;
580 u->flags.position = POSITION_ASIS;
581 u->flags.sign = SIGN_SUPPRESS;
582 u->flags.decimal = DECIMAL_POINT;
583 u->flags.delim = DELIM_UNSPECIFIED;
584 u->flags.encoding = ENCODING_DEFAULT;
585 u->flags.async = ASYNC_NO;
586 u->flags.round = ROUND_UNSPECIFIED;
587
588 u->recl = options.default_recl;
589 u->endfile = NO_ENDFILE;
590
591 u->file_len = strlen (stdin_name);
592 u->file = xmalloc (u->file_len);
593 memmove (u->file, stdin_name, u->file_len);
594
595 fbuf_init (u, 0);
596
597 __gthread_mutex_unlock (&u->lock);
598 }
599
600 if (options.stdout_unit >= 0)
601 { /* STDOUT */
602 u = insert_unit (options.stdout_unit);
603 u->s = output_stream ();
604
605 u->flags.action = ACTION_WRITE;
606
607 u->flags.access = ACCESS_SEQUENTIAL;
608 u->flags.form = FORM_FORMATTED;
609 u->flags.status = STATUS_OLD;
610 u->flags.blank = BLANK_NULL;
611 u->flags.position = POSITION_ASIS;
612 u->flags.sign = SIGN_SUPPRESS;
613 u->flags.decimal = DECIMAL_POINT;
614 u->flags.delim = DELIM_UNSPECIFIED;
615 u->flags.encoding = ENCODING_DEFAULT;
616 u->flags.async = ASYNC_NO;
617 u->flags.round = ROUND_UNSPECIFIED;
618
619 u->recl = options.default_recl;
620 u->endfile = AT_ENDFILE;
621
622 u->file_len = strlen (stdout_name);
623 u->file = xmalloc (u->file_len);
624 memmove (u->file, stdout_name, u->file_len);
625
626 fbuf_init (u, 0);
627
628 __gthread_mutex_unlock (&u->lock);
629 }
630
631 if (options.stderr_unit >= 0)
632 { /* STDERR */
633 u = insert_unit (options.stderr_unit);
634 u->s = error_stream ();
635
636 u->flags.action = ACTION_WRITE;
637
638 u->flags.access = ACCESS_SEQUENTIAL;
639 u->flags.form = FORM_FORMATTED;
640 u->flags.status = STATUS_OLD;
641 u->flags.blank = BLANK_NULL;
642 u->flags.position = POSITION_ASIS;
643 u->flags.sign = SIGN_SUPPRESS;
644 u->flags.decimal = DECIMAL_POINT;
645 u->flags.encoding = ENCODING_DEFAULT;
646 u->flags.async = ASYNC_NO;
647 u->flags.round = ROUND_UNSPECIFIED;
648
649 u->recl = options.default_recl;
650 u->endfile = AT_ENDFILE;
651
652 u->file_len = strlen (stderr_name);
653 u->file = xmalloc (u->file_len);
654 memmove (u->file, stderr_name, u->file_len);
655
656 fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
657 any kind of exotic formatting to stderr. */
658
659 __gthread_mutex_unlock (&u->lock);
660 }
661
662 /* Calculate the maximum file offset in a portable manner.
663 max will be the largest signed number for the type gfc_offset.
664 set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
665 max_offset = 0;
666 for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
667 max_offset = max_offset + ((gfc_offset) 1 << i);
668 }
669
670
671 static int
close_unit_1(gfc_unit * u,int locked)672 close_unit_1 (gfc_unit *u, int locked)
673 {
674 int i, rc;
675
676 /* If there are previously written bytes from a write with ADVANCE="no"
677 Reposition the buffer before closing. */
678 if (u->previous_nonadvancing_write)
679 finish_last_advance_record (u);
680
681 rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
682
683 u->closed = 1;
684 if (!locked)
685 __gthread_mutex_lock (&unit_lock);
686
687 for (i = 0; i < CACHE_SIZE; i++)
688 if (unit_cache[i] == u)
689 unit_cache[i] = NULL;
690
691 delete_unit (u);
692
693 free (u->file);
694 u->file = NULL;
695 u->file_len = 0;
696
697 free_format_hash_table (u);
698 fbuf_destroy (u);
699
700 if (!locked)
701 __gthread_mutex_unlock (&u->lock);
702
703 /* If there are any threads waiting in find_unit for this unit,
704 avoid freeing the memory, the last such thread will free it
705 instead. */
706 if (u->waiting == 0)
707 destroy_unit_mutex (u);
708
709 if (!locked)
710 __gthread_mutex_unlock (&unit_lock);
711
712 return rc;
713 }
714
715 void
unlock_unit(gfc_unit * u)716 unlock_unit (gfc_unit *u)
717 {
718 __gthread_mutex_unlock (&u->lock);
719 }
720
721 /* close_unit()-- Close a unit. The stream is closed, and any memory
722 associated with the stream is freed. Returns nonzero on I/O error.
723 Should be called with the u->lock locked. */
724
725 int
close_unit(gfc_unit * u)726 close_unit (gfc_unit *u)
727 {
728 return close_unit_1 (u, 0);
729 }
730
731
732 /* close_units()-- Delete units on completion. We just keep deleting
733 the root of the treap until there is nothing left.
734 Not sure what to do with locking here. Some other thread might be
735 holding some unit's lock and perhaps hold it indefinitely
736 (e.g. waiting for input from some pipe) and close_units shouldn't
737 delay the program too much. */
738
739 void
close_units(void)740 close_units (void)
741 {
742 __gthread_mutex_lock (&unit_lock);
743 while (unit_root != NULL)
744 close_unit_1 (unit_root, 1);
745 __gthread_mutex_unlock (&unit_lock);
746 }
747
748
749 /* High level interface to truncate a file, i.e. flush format buffers,
750 and generate an error or set some flags. Just like POSIX
751 ftruncate, returns 0 on success, -1 on failure. */
752
753 int
unit_truncate(gfc_unit * u,gfc_offset pos,st_parameter_common * common)754 unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
755 {
756 int ret;
757
758 /* Make sure format buffer is flushed. */
759 if (u->flags.form == FORM_FORMATTED)
760 {
761 if (u->mode == READING)
762 pos += fbuf_reset (u);
763 else
764 fbuf_flush (u, u->mode);
765 }
766
767 /* struncate() should flush the stream buffer if necessary, so don't
768 bother calling sflush() here. */
769 ret = struncate (u->s, pos);
770
771 if (ret != 0)
772 generate_error (common, LIBERROR_OS, NULL);
773 else
774 {
775 u->endfile = AT_ENDFILE;
776 u->flags.position = POSITION_APPEND;
777 }
778
779 return ret;
780 }
781
782
783 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
784 name of the associated file, otherwise return the empty string. The caller
785 must free memory allocated for the filename string. */
786
787 char *
filename_from_unit(int n)788 filename_from_unit (int n)
789 {
790 char *filename;
791 gfc_unit *u;
792 int c;
793
794 /* Find the unit. */
795 u = unit_root;
796 while (u != NULL)
797 {
798 c = compare (n, u->unit_number);
799 if (c < 0)
800 u = u->left;
801 if (c > 0)
802 u = u->right;
803 if (c == 0)
804 break;
805 }
806
807 /* Get the filename. */
808 if (u != NULL)
809 {
810 filename = (char *) xmalloc (u->file_len + 1);
811 unpack_filename (filename, u->file, u->file_len);
812 return filename;
813 }
814 else
815 return (char *) NULL;
816 }
817
818 void
finish_last_advance_record(gfc_unit * u)819 finish_last_advance_record (gfc_unit *u)
820 {
821
822 if (u->saved_pos > 0)
823 fbuf_seek (u, u->saved_pos, SEEK_CUR);
824
825 if (!(u->unit_number == options.stdout_unit
826 || u->unit_number == options.stderr_unit))
827 {
828 #ifdef HAVE_CRLF
829 const int len = 2;
830 #else
831 const int len = 1;
832 #endif
833 char *p = fbuf_alloc (u, len);
834 if (!p)
835 os_error ("Completing record after ADVANCE_NO failed");
836 #ifdef HAVE_CRLF
837 *(p++) = '\r';
838 #endif
839 *p = '\n';
840 }
841
842 fbuf_flush (u, u->mode);
843 }
844
845 /* Assign a negative number for NEWUNIT in OPEN statements. */
846 GFC_INTEGER_4
get_unique_unit_number(st_parameter_open * opp)847 get_unique_unit_number (st_parameter_open *opp)
848 {
849 GFC_INTEGER_4 num;
850
851 #ifdef HAVE_SYNC_FETCH_AND_ADD
852 num = __sync_fetch_and_add (&next_available_newunit, -1);
853 #else
854 __gthread_mutex_lock (&unit_lock);
855 num = next_available_newunit--;
856 __gthread_mutex_unlock (&unit_lock);
857 #endif
858
859 /* Do not allow NEWUNIT numbers to wrap. */
860 if (num > GFC_FIRST_NEWUNIT)
861 {
862 generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
863 return 0;
864 }
865 return num;
866 }
867