OSDN Git Service

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