libgfortran/io/unit.c

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