OSDN Git Service

PR 43839
[pf3gnuchains/gcc-fork.git] / libgfortran / io / unit.c
1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010 
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4    F2003 I/O support contributed by Jerry DeLisle
5
6 This file is part of the GNU Fortran runtime library (libgfortran).
7
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
12
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25 <http://www.gnu.org/licenses/>.  */
26
27 #include "io.h"
28 #include "fbuf.h"
29 #include "format.h"
30 #include "unix.h"
31 #include <stdlib.h>
32 #include <string.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 /* Subroutines related to units */
73
74 GFC_INTEGER_4 next_available_newunit;
75 #define GFC_FIRST_NEWUNIT -10
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
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 *
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 *
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
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 *
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 *
188 insert_unit (int n)
189 {
190   gfc_unit *u = get_mem (sizeof (gfc_unit));
191   memset (u, '\0', sizeof (gfc_unit));
192   u->unit_number = n;
193 #ifdef __GTHREAD_MUTEX_INIT
194   {
195     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
196     u->lock = tmp;
197   }
198 #else
199   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
200 #endif
201   __gthread_mutex_lock (&u->lock);
202   u->priority = pseudo_random ();
203   unit_root = insert (u, unit_root);
204   return u;
205 }
206
207
208 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit.  */
209
210 static void
211 destroy_unit_mutex (gfc_unit * u)
212 {
213   __gthread_mutex_destroy (&u->lock);
214   free (u);
215 }
216
217
218 static gfc_unit *
219 delete_root (gfc_unit * t)
220 {
221   gfc_unit *temp;
222
223   if (t->left == NULL)
224     return t->right;
225   if (t->right == NULL)
226     return t->left;
227
228   if (t->left->priority > t->right->priority)
229     {
230       temp = rotate_right (t);
231       temp->right = delete_root (t);
232     }
233   else
234     {
235       temp = rotate_left (t);
236       temp->left = delete_root (t);
237     }
238
239   return temp;
240 }
241
242
243 /* delete_treap()-- Delete an element from a tree.  The 'old' value
244  * does not necessarily have to point to the element to be deleted, it
245  * must just point to a treap structure with the key to be deleted.
246  * Returns the new root node of the tree. */
247
248 static gfc_unit *
249 delete_treap (gfc_unit * old, gfc_unit * t)
250 {
251   int c;
252
253   if (t == NULL)
254     return NULL;
255
256   c = compare (old->unit_number, t->unit_number);
257
258   if (c < 0)
259     t->left = delete_treap (old, t->left);
260   if (c > 0)
261     t->right = delete_treap (old, t->right);
262   if (c == 0)
263     t = delete_root (t);
264
265   return t;
266 }
267
268
269 /* delete_unit()-- Delete a unit from a tree */
270
271 static void
272 delete_unit (gfc_unit * old)
273 {
274   unit_root = delete_treap (old, unit_root);
275 }
276
277
278 /* get_external_unit()-- Given an integer, return a pointer to the unit
279  * structure.  Returns NULL if the unit does not exist,
280  * otherwise returns a locked unit. */
281
282 static gfc_unit *
283 get_external_unit (int n, int do_create)
284 {
285   gfc_unit *p;
286   int c, created = 0;
287
288   __gthread_mutex_lock (&unit_lock);
289 retry:
290   for (c = 0; c < CACHE_SIZE; c++)
291     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
292       {
293         p = unit_cache[c];
294         goto found;
295       }
296
297   p = unit_root;
298   while (p != NULL)
299     {
300       c = compare (n, p->unit_number);
301       if (c < 0)
302         p = p->left;
303       if (c > 0)
304         p = p->right;
305       if (c == 0)
306         break;
307     }
308
309   if (p == NULL && do_create)
310     {
311       p = insert_unit (n);
312       created = 1;
313     }
314
315   if (p != NULL)
316     {
317       for (c = 0; c < CACHE_SIZE - 1; c++)
318         unit_cache[c] = unit_cache[c + 1];
319
320       unit_cache[CACHE_SIZE - 1] = p;
321     }
322
323   if (created)
324     {
325       /* Newly created units have their lock held already
326          from insert_unit.  Just unlock UNIT_LOCK and return.  */
327       __gthread_mutex_unlock (&unit_lock);
328       return p;
329     }
330
331 found:
332   if (p != NULL)
333     {
334       /* Fast path.  */
335       if (! __gthread_mutex_trylock (&p->lock))
336         {
337           /* assert (p->closed == 0); */
338           __gthread_mutex_unlock (&unit_lock);
339           return p;
340         }
341
342       inc_waiting_locked (p);
343     }
344
345   __gthread_mutex_unlock (&unit_lock);
346
347   if (p != NULL)
348     {
349       __gthread_mutex_lock (&p->lock);
350       if (p->closed)
351         {
352           __gthread_mutex_lock (&unit_lock);
353           __gthread_mutex_unlock (&p->lock);
354           if (predec_waiting_locked (p) == 0)
355             destroy_unit_mutex (p);
356           goto retry;
357         }
358
359       dec_waiting_unlocked (p);
360     }
361   return p;
362 }
363
364
365 gfc_unit *
366 find_unit (int n)
367 {
368   return get_external_unit (n, 0);
369 }
370
371
372 gfc_unit *
373 find_or_create_unit (int n)
374 {
375   return get_external_unit (n, 1);
376 }
377
378
379 gfc_unit *
380 get_internal_unit (st_parameter_dt *dtp)
381 {
382   gfc_unit * iunit;
383   gfc_offset start_record = 0;
384
385   /* Allocate memory for a unit structure.  */
386
387   iunit = get_mem (sizeof (gfc_unit));
388   if (iunit == NULL)
389     {
390       generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
391       return NULL;
392     }
393
394   memset (iunit, '\0', sizeof (gfc_unit));
395 #ifdef __GTHREAD_MUTEX_INIT
396   {
397     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
398     iunit->lock = tmp;
399   }
400 #else
401   __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
402 #endif
403   __gthread_mutex_lock (&iunit->lock);
404
405   iunit->recl = dtp->internal_unit_len;
406   
407   /* For internal units we set the unit number to -1.
408      Otherwise internal units can be mistaken for a pre-connected unit or
409      some other file I/O unit.  */
410   iunit->unit_number = -1;
411
412   /* Set up the looping specification from the array descriptor, if any.  */
413
414   if (is_array_io (dtp))
415     {
416       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
417       iunit->ls = (array_loop_spec *)
418         get_mem (iunit->rank * sizeof (array_loop_spec));
419       dtp->internal_unit_len *=
420         init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
421
422       start_record *= iunit->recl;
423     }
424
425   /* Set initial values for unit parameters.  */
426
427   iunit->s = open_internal (dtp->internal_unit - start_record,
428                             dtp->internal_unit_len, -start_record);
429   iunit->bytes_left = iunit->recl;
430   iunit->last_record=0;
431   iunit->maxrec=0;
432   iunit->current_record=0;
433   iunit->read_bad = 0;
434   iunit->endfile = NO_ENDFILE;
435
436   /* Set flags for the internal unit.  */
437
438   iunit->flags.access = ACCESS_SEQUENTIAL;
439   iunit->flags.action = ACTION_READWRITE;
440   iunit->flags.blank = BLANK_NULL;
441   iunit->flags.form = FORM_FORMATTED;
442   iunit->flags.pad = PAD_YES;
443   iunit->flags.status = STATUS_UNSPECIFIED;
444   iunit->flags.sign = SIGN_SUPPRESS;
445   iunit->flags.decimal = DECIMAL_POINT;
446   iunit->flags.encoding = ENCODING_DEFAULT;
447   iunit->flags.async = ASYNC_NO;
448   iunit->flags.round = ROUND_COMPATIBLE;
449
450   /* Initialize the data transfer parameters.  */
451
452   dtp->u.p.advance_status = ADVANCE_YES;
453   dtp->u.p.seen_dollar = 0;
454   dtp->u.p.skips = 0;
455   dtp->u.p.pending_spaces = 0;
456   dtp->u.p.max_pos = 0;
457   dtp->u.p.at_eof = 0;
458
459   /* This flag tells us the unit is assigned to internal I/O.  */
460   
461   dtp->u.p.unit_is_internal = 1;
462
463   return iunit;
464 }
465
466
467 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
468 void
469 free_internal_unit (st_parameter_dt *dtp)
470 {
471   if (!is_internal_unit (dtp))
472     return;
473
474   if (dtp->u.p.current_unit != NULL)
475     {
476       if (dtp->u.p.current_unit->ls != NULL)
477         free (dtp->u.p.current_unit->ls);
478   
479       if (dtp->u.p.current_unit->s)
480         free (dtp->u.p.current_unit->s);
481   
482       destroy_unit_mutex (dtp->u.p.current_unit);
483     }
484 }
485       
486
487
488 /* get_unit()-- Returns the unit structure associated with the integer
489    unit or the internal file.  */
490
491 gfc_unit *
492 get_unit (st_parameter_dt *dtp, int do_create)
493 {
494
495   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
496     return get_internal_unit(dtp);
497
498   /* Has to be an external unit.  */
499
500   dtp->u.p.unit_is_internal = 0;
501   dtp->internal_unit_desc = NULL;
502
503   return get_external_unit (dtp->common.unit, do_create);
504 }
505
506
507 /*************************/
508 /* Initialize everything.  */
509
510 void
511 init_units (void)
512 {
513   gfc_unit *u;
514   unsigned int i;
515
516 #ifndef __GTHREAD_MUTEX_INIT
517   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
518 #endif
519
520   next_available_newunit = GFC_FIRST_NEWUNIT;
521
522   if (options.stdin_unit >= 0)
523     {                           /* STDIN */
524       u = insert_unit (options.stdin_unit);
525       u->s = input_stream ();
526
527       u->flags.action = ACTION_READ;
528
529       u->flags.access = ACCESS_SEQUENTIAL;
530       u->flags.form = FORM_FORMATTED;
531       u->flags.status = STATUS_OLD;
532       u->flags.blank = BLANK_NULL;
533       u->flags.pad = PAD_YES;
534       u->flags.position = POSITION_ASIS;
535       u->flags.sign = SIGN_SUPPRESS;
536       u->flags.decimal = DECIMAL_POINT;
537       u->flags.encoding = ENCODING_DEFAULT;
538       u->flags.async = ASYNC_NO;
539       u->flags.round = ROUND_COMPATIBLE;
540      
541       u->recl = options.default_recl;
542       u->endfile = NO_ENDFILE;
543
544       u->file_len = strlen (stdin_name);
545       u->file = get_mem (u->file_len);
546       memmove (u->file, stdin_name, u->file_len);
547
548       fbuf_init (u, 0);
549     
550       __gthread_mutex_unlock (&u->lock);
551     }
552
553   if (options.stdout_unit >= 0)
554     {                           /* STDOUT */
555       u = insert_unit (options.stdout_unit);
556       u->s = output_stream ();
557
558       u->flags.action = ACTION_WRITE;
559
560       u->flags.access = ACCESS_SEQUENTIAL;
561       u->flags.form = FORM_FORMATTED;
562       u->flags.status = STATUS_OLD;
563       u->flags.blank = BLANK_NULL;
564       u->flags.position = POSITION_ASIS;
565       u->flags.sign = SIGN_SUPPRESS;
566       u->flags.decimal = DECIMAL_POINT;
567       u->flags.encoding = ENCODING_DEFAULT;
568       u->flags.async = ASYNC_NO;
569       u->flags.round = ROUND_COMPATIBLE;
570
571       u->recl = options.default_recl;
572       u->endfile = AT_ENDFILE;
573     
574       u->file_len = strlen (stdout_name);
575       u->file = get_mem (u->file_len);
576       memmove (u->file, stdout_name, u->file_len);
577       
578       fbuf_init (u, 0);
579
580       __gthread_mutex_unlock (&u->lock);
581     }
582
583   if (options.stderr_unit >= 0)
584     {                           /* STDERR */
585       u = insert_unit (options.stderr_unit);
586       u->s = error_stream ();
587
588       u->flags.action = ACTION_WRITE;
589
590       u->flags.access = ACCESS_SEQUENTIAL;
591       u->flags.form = FORM_FORMATTED;
592       u->flags.status = STATUS_OLD;
593       u->flags.blank = BLANK_NULL;
594       u->flags.position = POSITION_ASIS;
595       u->flags.sign = SIGN_SUPPRESS;
596       u->flags.decimal = DECIMAL_POINT;
597       u->flags.encoding = ENCODING_DEFAULT;
598       u->flags.async = ASYNC_NO;
599       u->flags.round = ROUND_COMPATIBLE;
600
601       u->recl = options.default_recl;
602       u->endfile = AT_ENDFILE;
603
604       u->file_len = strlen (stderr_name);
605       u->file = get_mem (u->file_len);
606       memmove (u->file, stderr_name, u->file_len);
607       
608       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
609                               any kind of exotic formatting to stderr.  */
610
611       __gthread_mutex_unlock (&u->lock);
612     }
613
614   /* Calculate the maximum file offset in a portable manner.
615      max will be the largest signed number for the type gfc_offset.
616      set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
617   max_offset = 0;
618   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
619     max_offset = max_offset + ((gfc_offset) 1 << i);
620 }
621
622
623 static int
624 close_unit_1 (gfc_unit *u, int locked)
625 {
626   int i, rc;
627   
628   /* If there are previously written bytes from a write with ADVANCE="no"
629      Reposition the buffer before closing.  */
630   if (u->previous_nonadvancing_write)
631     finish_last_advance_record (u);
632
633   rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
634
635   u->closed = 1;
636   if (!locked)
637     __gthread_mutex_lock (&unit_lock);
638
639   for (i = 0; i < CACHE_SIZE; i++)
640     if (unit_cache[i] == u)
641       unit_cache[i] = NULL;
642
643   delete_unit (u);
644
645   if (u->file)
646     free (u->file);
647   u->file = NULL;
648   u->file_len = 0;
649
650   free_format_hash_table (u);  
651   fbuf_destroy (u);
652
653   if (!locked)
654     __gthread_mutex_unlock (&u->lock);
655
656   /* If there are any threads waiting in find_unit for this unit,
657      avoid freeing the memory, the last such thread will free it
658      instead.  */
659   if (u->waiting == 0)
660     destroy_unit_mutex (u);
661
662   if (!locked)
663     __gthread_mutex_unlock (&unit_lock);
664
665   return rc;
666 }
667
668 void
669 unlock_unit (gfc_unit *u)
670 {
671   __gthread_mutex_unlock (&u->lock);
672 }
673
674 /* close_unit()-- Close a unit.  The stream is closed, and any memory
675    associated with the stream is freed.  Returns nonzero on I/O error.
676    Should be called with the u->lock locked. */
677
678 int
679 close_unit (gfc_unit *u)
680 {
681   return close_unit_1 (u, 0);
682 }
683
684
685 /* close_units()-- Delete units on completion.  We just keep deleting
686    the root of the treap until there is nothing left.
687    Not sure what to do with locking here.  Some other thread might be
688    holding some unit's lock and perhaps hold it indefinitely
689    (e.g. waiting for input from some pipe) and close_units shouldn't
690    delay the program too much.  */
691
692 void
693 close_units (void)
694 {
695   __gthread_mutex_lock (&unit_lock);
696   while (unit_root != NULL)
697     close_unit_1 (unit_root, 1);
698   __gthread_mutex_unlock (&unit_lock);
699 }
700
701
702 /* update_position()-- Update the flags position for later use by inquire.  */
703
704 void
705 update_position (gfc_unit *u)
706 {
707   if (stell (u->s) == 0)
708     u->flags.position = POSITION_REWIND;
709   else if (file_length (u->s) == stell (u->s))
710     u->flags.position = POSITION_APPEND;
711   else
712     u->flags.position = POSITION_ASIS;
713 }
714
715
716 /* High level interface to truncate a file safely, i.e. flush format
717    buffers, check that it's a regular file, and generate error if that
718    occurs.  Just like POSIX ftruncate, returns 0 on success, -1 on
719    failure.  */
720
721 int
722 unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
723 {
724   int ret;
725
726   /* Make sure format buffer is flushed.  */
727   if (u->flags.form == FORM_FORMATTED)
728     {
729       if (u->mode == READING)
730         pos += fbuf_reset (u);
731       else
732         fbuf_flush (u, u->mode);
733     }
734   
735   /* Don't try to truncate a special file, just pretend that it
736      succeeds.  */
737   if (is_special (u->s) || !is_seekable (u->s))
738     {
739       sflush (u->s);
740       return 0;
741     }
742
743   /* struncate() should flush the stream buffer if necessary, so don't
744      bother calling sflush() here.  */
745   ret = struncate (u->s, pos);
746
747   if (ret != 0)
748     {
749       generate_error (common, LIBERROR_OS, NULL);
750       u->endfile = NO_ENDFILE;
751       u->flags.position = POSITION_ASIS;
752     }
753   else
754     {
755       u->endfile = AT_ENDFILE;
756       u->flags.position = POSITION_APPEND;
757     }
758
759   return ret;
760 }
761
762
763 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
764    name of the associated file, otherwise return the empty string.  The caller
765    must free memory allocated for the filename string.  */
766
767 char *
768 filename_from_unit (int n)
769 {
770   char *filename;
771   gfc_unit *u;
772   int c;
773
774   /* Find the unit.  */
775   u = unit_root;
776   while (u != NULL)
777     {
778       c = compare (n, u->unit_number);
779       if (c < 0)
780         u = u->left;
781       if (c > 0)
782         u = u->right;
783       if (c == 0)
784         break;
785     }
786
787   /* Get the filename.  */
788   if (u != NULL)
789     {
790       filename = (char *) get_mem (u->file_len + 1);
791       unpack_filename (filename, u->file, u->file_len);
792       return filename;
793     }
794   else
795     return (char *) NULL;
796 }
797
798 void
799 finish_last_advance_record (gfc_unit *u)
800 {
801   
802   if (u->saved_pos > 0)
803     fbuf_seek (u, u->saved_pos, SEEK_CUR);
804
805   if (!(u->unit_number == options.stdout_unit
806         || u->unit_number == options.stderr_unit))
807     {
808 #ifdef HAVE_CRLF
809       const int len = 2;
810 #else
811       const int len = 1;
812 #endif
813       char *p = fbuf_alloc (u, len);
814       if (!p)
815         os_error ("Completing record after ADVANCE_NO failed");
816 #ifdef HAVE_CRLF
817       *(p++) = '\r';
818 #endif
819       *p = '\n';
820     }
821
822   fbuf_flush (u, u->mode);
823 }
824
825 /* Assign a negative number for NEWUNIT in OPEN statements.  */
826 GFC_INTEGER_4
827 get_unique_unit_number (st_parameter_open *opp)
828 {
829   GFC_INTEGER_4 num;
830
831   __gthread_mutex_lock (&unit_lock);
832   num = next_available_newunit--;
833
834   /* Do not allow NEWUNIT numbers to wrap.  */
835   if (next_available_newunit >=  GFC_FIRST_NEWUNIT )
836     {
837       __gthread_mutex_unlock (&unit_lock);
838       generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
839       return 0;
840     }
841   __gthread_mutex_unlock (&unit_lock);
842   return num;
843 }