libgfortran/io/unit.c

   1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010, 2011, 2012
   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 = xcalloc (1, 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 = xcalloc (1, sizeof (gfc_unit));
 388
 389 #ifdef __GTHREAD_MUTEX_INIT
 390   {
 391     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
 392     iunit->lock = tmp;
 393   }
 394 #else
 395   __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
 396 #endif
 397   __gthread_mutex_lock (&iunit->lock);
 398
 399   iunit->recl = dtp->internal_unit_len;
 400
 401   /* For internal units we set the unit number to -1.
 402      Otherwise internal units can be mistaken for a pre-connected unit or
 403      some other file I/O unit.  */
 404   iunit->unit_number = -1;
 405
 406   /* Set up the looping specification from the array descriptor, if any.  */
 407
 408   if (is_array_io (dtp))
 409     {
 410       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
 411       iunit->ls = (array_loop_spec *)
 412         get_mem (iunit->rank * sizeof (array_loop_spec));
 413       dtp->internal_unit_len *=
 414         init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
 415
 416       start_record *= iunit->recl;
 417     }
 418
 419   /* Set initial values for unit parameters.  */
 420   if (dtp->common.unit)
 421     {
 422       iunit->s = open_internal4 (dtp->internal_unit - start_record,
 423                                  dtp->internal_unit_len, -start_record);
 424       fbuf_init (iunit, 256);
 425     }
 426   else
 427     iunit->s = open_internal (dtp->internal_unit - start_record,
 428                               dtp->internal_unit_len, -start_record);
 429
 430   iunit->bytes_left = iunit->recl;
 431   iunit->last_record=0;
 432   iunit->maxrec=0;
 433   iunit->current_record=0;
 434   iunit->read_bad = 0;
 435   iunit->endfile = NO_ENDFILE;
 436
 437   /* Set flags for the internal unit.  */
 438
 439   iunit->flags.access = ACCESS_SEQUENTIAL;
 440   iunit->flags.action = ACTION_READWRITE;
 441   iunit->flags.blank = BLANK_NULL;
 442   iunit->flags.form = FORM_FORMATTED;
 443   iunit->flags.pad = PAD_YES;
 444   iunit->flags.status = STATUS_UNSPECIFIED;
 445   iunit->flags.sign = SIGN_SUPPRESS;
 446   iunit->flags.decimal = DECIMAL_POINT;
 447   iunit->flags.encoding = ENCODING_DEFAULT;
 448   iunit->flags.async = ASYNC_NO;
 449   iunit->flags.round = ROUND_UNSPECIFIED;
 450
 451   /* Initialize the data transfer parameters.  */
 452
 453   dtp->u.p.advance_status = ADVANCE_YES;
 454   dtp->u.p.seen_dollar = 0;
 455   dtp->u.p.skips = 0;
 456   dtp->u.p.pending_spaces = 0;
 457   dtp->u.p.max_pos = 0;
 458   dtp->u.p.at_eof = 0;
 459
 460   /* This flag tells us the unit is assigned to internal I/O.  */
 461
 462   dtp->u.p.unit_is_internal = 1;
 463
 464   return iunit;
 465 }
 466
 467
 468 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
 469 void
 470 free_internal_unit (st_parameter_dt *dtp)
 471 {
 472   if (!is_internal_unit (dtp))
 473     return;
 474
 475   if (unlikely (is_char4_unit (dtp)))
 476     fbuf_destroy (dtp->u.p.current_unit);
 477
 478   if (dtp->u.p.current_unit != NULL)
 479     {
 480       free (dtp->u.p.current_unit->ls);
 481
 482       free (dtp->u.p.current_unit->s);
 483
 484       destroy_unit_mutex (dtp->u.p.current_unit);
 485     }
 486 }
 487
 488
 489
 490 /* get_unit()-- Returns the unit structure associated with the integer
 491    unit or the internal file.  */
 492
 493 gfc_unit *
 494 get_unit (st_parameter_dt *dtp, int do_create)
 495 {
 496
 497   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 498     return get_internal_unit (dtp);
 499
 500   /* Has to be an external unit.  */
 501
 502   dtp->u.p.unit_is_internal = 0;
 503   dtp->internal_unit_desc = NULL;
 504
 505   return get_external_unit (dtp->common.unit, do_create);
 506 }
 507
 508
 509 /*************************/
 510 /* Initialize everything.  */
 511
 512 void
 513 init_units (void)
 514 {
 515   gfc_unit *u;
 516   unsigned int i;
 517
 518 #ifndef __GTHREAD_MUTEX_INIT
 519   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 520 #endif
 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_UNSPECIFIED;
 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_UNSPECIFIED;
 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_UNSPECIFIED;
 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   free (u->file);
 646   u->file = NULL;
 647   u->file_len = 0;
 648
 649   free_format_hash_table (u);
 650   fbuf_destroy (u);
 651
 652   if (!locked)
 653     __gthread_mutex_unlock (&u->lock);
 654
 655   /* If there are any threads waiting in find_unit for this unit,
 656      avoid freeing the memory, the last such thread will free it
 657      instead.  */
 658   if (u->waiting == 0)
 659     destroy_unit_mutex (u);
 660
 661   if (!locked)
 662     __gthread_mutex_unlock (&unit_lock);
 663
 664   return rc;
 665 }
 666
 667 void
 668 unlock_unit (gfc_unit *u)
 669 {
 670   __gthread_mutex_unlock (&u->lock);
 671 }
 672
 673 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 674    associated with the stream is freed.  Returns nonzero on I/O error.
 675    Should be called with the u->lock locked. */
 676
 677 int
 678 close_unit (gfc_unit *u)
 679 {
 680   return close_unit_1 (u, 0);
 681 }
 682
 683
 684 /* close_units()-- Delete units on completion.  We just keep deleting
 685    the root of the treap until there is nothing left.
 686    Not sure what to do with locking here.  Some other thread might be
 687    holding some unit's lock and perhaps hold it indefinitely
 688    (e.g. waiting for input from some pipe) and close_units shouldn't
 689    delay the program too much.  */
 690
 691 void
 692 close_units (void)
 693 {
 694   __gthread_mutex_lock (&unit_lock);
 695   while (unit_root != NULL)
 696     close_unit_1 (unit_root, 1);
 697   __gthread_mutex_unlock (&unit_lock);
 698 }
 699
 700
 701 /* High level interface to truncate a file, i.e. flush format buffers,
 702    and generate an error or set some flags.  Just like POSIX
 703    ftruncate, returns 0 on success, -1 on failure.  */
 704
 705 int
 706 unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
 707 {
 708   int ret;
 709
 710   /* Make sure format buffer is flushed.  */
 711   if (u->flags.form == FORM_FORMATTED)
 712     {
 713       if (u->mode == READING)
 714         pos += fbuf_reset (u);
 715       else
 716         fbuf_flush (u, u->mode);
 717     }
 718
 719   /* struncate() should flush the stream buffer if necessary, so don't
 720      bother calling sflush() here.  */
 721   ret = struncate (u->s, pos);
 722
 723   if (ret != 0)
 724     generate_error (common, LIBERROR_OS, NULL);
 725   else
 726     {
 727       u->endfile = AT_ENDFILE;
 728       u->flags.position = POSITION_APPEND;
 729     }
 730
 731   return ret;
 732 }
 733
 734
 735 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 736    name of the associated file, otherwise return the empty string.  The caller
 737    must free memory allocated for the filename string.  */
 738
 739 char *
 740 filename_from_unit (int n)
 741 {
 742   char *filename;
 743   gfc_unit *u;
 744   int c;
 745
 746   /* Find the unit.  */
 747   u = unit_root;
 748   while (u != NULL)
 749     {
 750       c = compare (n, u->unit_number);
 751       if (c < 0)
 752         u = u->left;
 753       if (c > 0)
 754         u = u->right;
 755       if (c == 0)
 756         break;
 757     }
 758
 759   /* Get the filename.  */
 760   if (u != NULL)
 761     {
 762       filename = (char *) get_mem (u->file_len + 1);
 763       unpack_filename (filename, u->file, u->file_len);
 764       return filename;
 765     }
 766   else
 767     return (char *) NULL;
 768 }
 769
 770 void
 771 finish_last_advance_record (gfc_unit *u)
 772 {
 773
 774   if (u->saved_pos > 0)
 775     fbuf_seek (u, u->saved_pos, SEEK_CUR);
 776
 777   if (!(u->unit_number == options.stdout_unit
 778         || u->unit_number == options.stderr_unit))
 779     {
 780 #ifdef HAVE_CRLF
 781       const int len = 2;
 782 #else
 783       const int len = 1;
 784 #endif
 785       char *p = fbuf_alloc (u, len);
 786       if (!p)
 787         os_error ("Completing record after ADVANCE_NO failed");
 788 #ifdef HAVE_CRLF
 789       *(p++) = '\r';
 790 #endif
 791       *p = '\n';
 792     }
 793
 794   fbuf_flush (u, u->mode);
 795 }
 796
 797 /* Assign a negative number for NEWUNIT in OPEN statements.  */
 798 GFC_INTEGER_4
 799 get_unique_unit_number (st_parameter_open *opp)
 800 {
 801   GFC_INTEGER_4 num;
 802
 803 #ifdef HAVE_SYNC_FETCH_AND_ADD
 804   num = __sync_fetch_and_add (&next_available_newunit, -1);
 805 #else
 806   __gthread_mutex_lock (&unit_lock);
 807   num = next_available_newunit--;
 808   __gthread_mutex_unlock (&unit_lock);
 809 #endif
 810
 811   /* Do not allow NEWUNIT numbers to wrap.  */
 812   if (num > GFC_FIRST_NEWUNIT)
 813     {
 814       generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
 815       return 0;
 816     }
 817   return num;
 818 }