libgfortran/io/unit.c

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