libgfortran/io/unit.c

   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
 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 = 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
 210 destroy_unit_mutex (gfc_unit * u)
 211 {
 212   __gthread_mutex_destroy (&u->lock);
 213   free (u);
 214 }
 215
 216
 217 static gfc_unit *
 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 *
 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
 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 *
 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 *
 365 find_unit (int n)
 366 {
 367   return get_external_unit (n, 0);
 368 }
 369
 370
 371 gfc_unit *
 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
 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 *
 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
 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 *
 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
 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.encoding = ENCODING_DEFAULT;
 584       u->flags.async = ASYNC_NO;
 585       u->flags.round = ROUND_UNSPECIFIED;
 586
 587       u->recl = options.default_recl;
 588       u->endfile = NO_ENDFILE;
 589
 590       u->filename = strdup (stdin_name);
 591
 592       fbuf_init (u, 0);
 593
 594       __gthread_mutex_unlock (&u->lock);
 595     }
 596
 597   if (options.stdout_unit >= 0)
 598     {                           /* STDOUT */
 599       u = insert_unit (options.stdout_unit);
 600       u->s = output_stream ();
 601
 602       u->flags.action = ACTION_WRITE;
 603
 604       u->flags.access = ACCESS_SEQUENTIAL;
 605       u->flags.form = FORM_FORMATTED;
 606       u->flags.status = STATUS_OLD;
 607       u->flags.blank = BLANK_NULL;
 608       u->flags.position = POSITION_ASIS;
 609       u->flags.sign = SIGN_SUPPRESS;
 610       u->flags.decimal = DECIMAL_POINT;
 611       u->flags.delim = DELIM_UNSPECIFIED;
 612       u->flags.encoding = ENCODING_DEFAULT;
 613       u->flags.async = ASYNC_NO;
 614       u->flags.round = ROUND_UNSPECIFIED;
 615
 616       u->recl = options.default_recl;
 617       u->endfile = AT_ENDFILE;
 618
 619       u->filename = strdup (stdout_name);
 620
 621       fbuf_init (u, 0);
 622
 623       __gthread_mutex_unlock (&u->lock);
 624     }
 625
 626   if (options.stderr_unit >= 0)
 627     {                           /* STDERR */
 628       u = insert_unit (options.stderr_unit);
 629       u->s = error_stream ();
 630
 631       u->flags.action = ACTION_WRITE;
 632
 633       u->flags.access = ACCESS_SEQUENTIAL;
 634       u->flags.form = FORM_FORMATTED;
 635       u->flags.status = STATUS_OLD;
 636       u->flags.blank = BLANK_NULL;
 637       u->flags.position = POSITION_ASIS;
 638       u->flags.sign = SIGN_SUPPRESS;
 639       u->flags.decimal = DECIMAL_POINT;
 640       u->flags.encoding = ENCODING_DEFAULT;
 641       u->flags.async = ASYNC_NO;
 642       u->flags.round = ROUND_UNSPECIFIED;
 643
 644       u->recl = options.default_recl;
 645       u->endfile = AT_ENDFILE;
 646
 647       u->filename = strdup (stderr_name);
 648
 649       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
 650                               any kind of exotic formatting to stderr.  */
 651
 652       __gthread_mutex_unlock (&u->lock);
 653     }
 654
 655   /* Calculate the maximum file offset in a portable manner.
 656      max will be the largest signed number for the type gfc_offset.
 657      set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
 658   max_offset = 0;
 659   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 660     max_offset = max_offset + ((gfc_offset) 1 << i);
 661 }
 662
 663
 664 static int
 665 close_unit_1 (gfc_unit *u, int locked)
 666 {
 667   int i, rc;
 668
 669   /* If there are previously written bytes from a write with ADVANCE="no"
 670      Reposition the buffer before closing.  */
 671   if (u->previous_nonadvancing_write)
 672     finish_last_advance_record (u);
 673
 674   rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
 675
 676   u->closed = 1;
 677   if (!locked)
 678     __gthread_mutex_lock (&unit_lock);
 679
 680   for (i = 0; i < CACHE_SIZE; i++)
 681     if (unit_cache[i] == u)
 682       unit_cache[i] = NULL;
 683
 684   delete_unit (u);
 685
 686   free (u->filename);
 687   u->filename = NULL;
 688
 689   free_format_hash_table (u);
 690   fbuf_destroy (u);
 691
 692   if (!locked)
 693     __gthread_mutex_unlock (&u->lock);
 694
 695   /* If there are any threads waiting in find_unit for this unit,
 696      avoid freeing the memory, the last such thread will free it
 697      instead.  */
 698   if (u->waiting == 0)
 699     destroy_unit_mutex (u);
 700
 701   if (!locked)
 702     __gthread_mutex_unlock (&unit_lock);
 703
 704   return rc;
 705 }
 706
 707 void
 708 unlock_unit (gfc_unit *u)
 709 {
 710   __gthread_mutex_unlock (&u->lock);
 711 }
 712
 713 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 714    associated with the stream is freed.  Returns nonzero on I/O error.
 715    Should be called with the u->lock locked. */
 716
 717 int
 718 close_unit (gfc_unit *u)
 719 {
 720   return close_unit_1 (u, 0);
 721 }
 722
 723
 724 /* close_units()-- Delete units on completion.  We just keep deleting
 725    the root of the treap until there is nothing left.
 726    Not sure what to do with locking here.  Some other thread might be
 727    holding some unit's lock and perhaps hold it indefinitely
 728    (e.g. waiting for input from some pipe) and close_units shouldn't
 729    delay the program too much.  */
 730
 731 void
 732 close_units (void)
 733 {
 734   __gthread_mutex_lock (&unit_lock);
 735   while (unit_root != NULL)
 736     close_unit_1 (unit_root, 1);
 737   __gthread_mutex_unlock (&unit_lock);
 738 }
 739
 740
 741 /* High level interface to truncate a file, i.e. flush format buffers,
 742    and generate an error or set some flags.  Just like POSIX
 743    ftruncate, returns 0 on success, -1 on failure.  */
 744
 745 int
 746 unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
 747 {
 748   int ret;
 749
 750   /* Make sure format buffer is flushed.  */
 751   if (u->flags.form == FORM_FORMATTED)
 752     {
 753       if (u->mode == READING)
 754         pos += fbuf_reset (u);
 755       else
 756         fbuf_flush (u, u->mode);
 757     }
 758
 759   /* struncate() should flush the stream buffer if necessary, so don't
 760      bother calling sflush() here.  */
 761   ret = struncate (u->s, pos);
 762
 763   if (ret != 0)
 764     generate_error (common, LIBERROR_OS, NULL);
 765   else
 766     {
 767       u->endfile = AT_ENDFILE;
 768       u->flags.position = POSITION_APPEND;
 769     }
 770
 771   return ret;
 772 }
 773
 774
 775 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 776    name of the associated file, otherwise return the empty string.  The caller
 777    must free memory allocated for the filename string.  */
 778
 779 char *
 780 filename_from_unit (int n)
 781 {
 782   gfc_unit *u;
 783   int c;
 784
 785   /* Find the unit.  */
 786   u = unit_root;
 787   while (u != NULL)
 788     {
 789       c = compare (n, u->unit_number);
 790       if (c < 0)
 791         u = u->left;
 792       if (c > 0)
 793         u = u->right;
 794       if (c == 0)
 795         break;
 796     }
 797
 798   /* Get the filename.  */
 799   if (u != NULL)
 800     return strdup (u->filename);
 801   else
 802     return (char *) NULL;
 803 }
 804
 805 void
 806 finish_last_advance_record (gfc_unit *u)
 807 {
 808
 809   if (u->saved_pos > 0)
 810     fbuf_seek (u, u->saved_pos, SEEK_CUR);
 811
 812   if (!(u->unit_number == options.stdout_unit
 813         || u->unit_number == options.stderr_unit))
 814     {
 815 #ifdef HAVE_CRLF
 816       const int len = 2;
 817 #else
 818       const int len = 1;
 819 #endif
 820       char *p = fbuf_alloc (u, len);
 821       if (!p)
 822         os_error ("Completing record after ADVANCE_NO failed");
 823 #ifdef HAVE_CRLF
 824       *(p++) = '\r';
 825 #endif
 826       *p = '\n';
 827     }
 828
 829   fbuf_flush (u, u->mode);
 830 }
 831
 832 /* Assign a negative number for NEWUNIT in OPEN statements.  */
 833 GFC_INTEGER_4
 834 get_unique_unit_number (st_parameter_open *opp)
 835 {
 836   GFC_INTEGER_4 num;
 837
 838 #ifdef HAVE_SYNC_FETCH_AND_ADD
 839   num = __sync_fetch_and_add (&next_available_newunit, -1);
 840 #else
 841   __gthread_mutex_lock (&unit_lock);
 842   num = next_available_newunit--;
 843   __gthread_mutex_unlock (&unit_lock);
 844 #endif
 845
 846   /* Do not allow NEWUNIT numbers to wrap.  */
 847   if (num > GFC_FIRST_NEWUNIT)
 848     {
 849       generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
 850       return 0;
 851     }
 852   return num;
 853 }