libgfortran/io/unit.c

   1 /* Copyright (C) 2002-2018 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_NEWLOCALE
 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 can not 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->unit_number = dtp->common.unit;
 460   iunit->recl = dtp->internal_unit_len;
 461   iunit->internal_unit = dtp->internal_unit;
 462   iunit->internal_unit_len = dtp->internal_unit_len;
 463   iunit->internal_unit_kind = kind;
 464
 465   /* As an optimization, adjust the unit record length to not
 466      include trailing blanks. This will not work under certain conditions
 467      where trailing blanks have significance.  */
 468   if (dtp->u.p.mode == READING && is_trim_ok (dtp))
 469     {
 470       int len;
 471       if (kind == 1)
 472           len = string_len_trim (iunit->internal_unit_len,
 473                                                    iunit->internal_unit);
 474       else
 475           len = string_len_trim_char4 (iunit->internal_unit_len,
 476                               (const gfc_char4_t*) iunit->internal_unit);
 477       iunit->internal_unit_len = len;
 478       iunit->recl = iunit->internal_unit_len;
 479     }
 480
 481   /* Set up the looping specification from the array descriptor, if any.  */
 482
 483   if (is_array_io (dtp))
 484     {
 485       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
 486       iunit->ls = (array_loop_spec *)
 487         xmallocarray (iunit->rank, sizeof (array_loop_spec));
 488       iunit->internal_unit_len *=
 489         init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
 490
 491       start_record *= iunit->recl;
 492     }
 493
 494   /* Set initial values for unit parameters.  */
 495   if (kind == 4)
 496     iunit->s = open_internal4 (iunit->internal_unit - start_record,
 497                                  iunit->internal_unit_len, -start_record);
 498   else
 499     iunit->s = open_internal (iunit->internal_unit - start_record,
 500                               iunit->internal_unit_len, -start_record);
 501
 502   iunit->bytes_left = iunit->recl;
 503   iunit->last_record=0;
 504   iunit->maxrec=0;
 505   iunit->current_record=0;
 506   iunit->read_bad = 0;
 507   iunit->endfile = NO_ENDFILE;
 508
 509   /* Set flags for the internal unit.  */
 510
 511   iunit->flags.access = ACCESS_SEQUENTIAL;
 512   iunit->flags.action = ACTION_READWRITE;
 513   iunit->flags.blank = BLANK_NULL;
 514   iunit->flags.form = FORM_FORMATTED;
 515   iunit->flags.pad = PAD_YES;
 516   iunit->flags.status = STATUS_UNSPECIFIED;
 517   iunit->flags.sign = SIGN_UNSPECIFIED;
 518   iunit->flags.decimal = DECIMAL_POINT;
 519   iunit->flags.delim = DELIM_UNSPECIFIED;
 520   iunit->flags.encoding = ENCODING_DEFAULT;
 521   iunit->flags.async = ASYNC_NO;
 522   iunit->flags.round = ROUND_UNSPECIFIED;
 523
 524   /* Initialize the data transfer parameters.  */
 525
 526   dtp->u.p.advance_status = ADVANCE_YES;
 527   dtp->u.p.seen_dollar = 0;
 528   dtp->u.p.skips = 0;
 529   dtp->u.p.pending_spaces = 0;
 530   dtp->u.p.max_pos = 0;
 531   dtp->u.p.at_eof = 0;
 532   return iunit;
 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   gfc_unit *unit;
 543
 544   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 545     {
 546       int kind;
 547       if (dtp->common.unit == GFC_INTERNAL_UNIT)
 548         kind = 1;
 549       else if (dtp->common.unit == GFC_INTERNAL_UNIT4)
 550         kind = 4;
 551       else
 552         internal_error (&dtp->common, "get_unit(): Bad internal unit KIND");
 553
 554       dtp->u.p.unit_is_internal = 1;
 555       dtp->common.unit = newunit_alloc ();
 556       unit = get_gfc_unit (dtp->common.unit, do_create);
 557       set_internal_unit (dtp, unit, kind);
 558       fbuf_init (unit, 128);
 559       return unit;
 560     }
 561
 562   /* Has to be an external unit.  */
 563   dtp->u.p.unit_is_internal = 0;
 564   dtp->internal_unit = NULL;
 565   dtp->internal_unit_desc = NULL;
 566
 567   /* For an external unit with unit number < 0 creating it on the fly
 568      is not allowed, such units must be created with
 569      OPEN(NEWUNIT=...).  */
 570   if (dtp->common.unit < 0)
 571     {
 572       if (dtp->common.unit > NEWUNIT_START) /* Reserved units.  */
 573         return NULL;
 574       return get_gfc_unit (dtp->common.unit, 0);
 575     }
 576
 577   return get_gfc_unit (dtp->common.unit, do_create);
 578 }
 579
 580
 581 /*************************/
 582 /* Initialize everything.  */
 583
 584 void
 585 init_units (void)
 586 {
 587   gfc_unit *u;
 588
 589 #ifdef HAVE_NEWLOCALE
 590   c_locale = newlocale (0, "C", 0);
 591 #else
 592 #ifndef __GTHREAD_MUTEX_INIT
 593   __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
 594 #endif
 595 #endif
 596
 597 #ifndef __GTHREAD_MUTEX_INIT
 598   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 599 #endif
 600
 601   if (sizeof (max_offset) == 8)
 602     {
 603       max_offset = GFC_INTEGER_8_HUGE;
 604       /* Why this weird value? Because if the recl specifier in the
 605          inquire statement is a 4 byte value, u->recl is truncated,
 606          and this trick ensures it becomes HUGE(0) rather than -1.
 607          The full 8 byte value of default_recl is still 0.99999999 *
 608          max_offset which is large enough for all practical
 609          purposes.  */
 610       default_recl = max_offset & ~(1LL<<31);
 611     }
 612   else if (sizeof (max_offset) == 4)
 613     max_offset = default_recl = GFC_INTEGER_4_HUGE;
 614   else
 615     internal_error (NULL, "sizeof (max_offset) must be 4 or 8");
 616
 617   if (options.stdin_unit >= 0)
 618     {                           /* STDIN */
 619       u = insert_unit (options.stdin_unit);
 620       u->s = input_stream ();
 621
 622       u->flags.action = ACTION_READ;
 623
 624       u->flags.access = ACCESS_SEQUENTIAL;
 625       u->flags.form = FORM_FORMATTED;
 626       u->flags.status = STATUS_OLD;
 627       u->flags.blank = BLANK_NULL;
 628       u->flags.pad = PAD_YES;
 629       u->flags.position = POSITION_ASIS;
 630       u->flags.sign = SIGN_UNSPECIFIED;
 631       u->flags.decimal = DECIMAL_POINT;
 632       u->flags.delim = DELIM_UNSPECIFIED;
 633       u->flags.encoding = ENCODING_DEFAULT;
 634       u->flags.async = ASYNC_NO;
 635       u->flags.round = ROUND_UNSPECIFIED;
 636       u->flags.share = SHARE_UNSPECIFIED;
 637       u->flags.cc = CC_LIST;
 638
 639       u->recl = default_recl;
 640       u->endfile = NO_ENDFILE;
 641
 642       u->filename = strdup (stdin_name);
 643
 644       fbuf_init (u, 0);
 645
 646       UNLOCK (&u->lock);
 647     }
 648
 649   if (options.stdout_unit >= 0)
 650     {                           /* STDOUT */
 651       u = insert_unit (options.stdout_unit);
 652       u->s = output_stream ();
 653
 654       u->flags.action = ACTION_WRITE;
 655
 656       u->flags.access = ACCESS_SEQUENTIAL;
 657       u->flags.form = FORM_FORMATTED;
 658       u->flags.status = STATUS_OLD;
 659       u->flags.blank = BLANK_NULL;
 660       u->flags.position = POSITION_ASIS;
 661       u->flags.sign = SIGN_UNSPECIFIED;
 662       u->flags.decimal = DECIMAL_POINT;
 663       u->flags.delim = DELIM_UNSPECIFIED;
 664       u->flags.encoding = ENCODING_DEFAULT;
 665       u->flags.async = ASYNC_NO;
 666       u->flags.round = ROUND_UNSPECIFIED;
 667       u->flags.share = SHARE_UNSPECIFIED;
 668       u->flags.cc = CC_LIST;
 669
 670       u->recl = default_recl;
 671       u->endfile = AT_ENDFILE;
 672
 673       u->filename = strdup (stdout_name);
 674
 675       fbuf_init (u, 0);
 676
 677       UNLOCK (&u->lock);
 678     }
 679
 680   if (options.stderr_unit >= 0)
 681     {                           /* STDERR */
 682       u = insert_unit (options.stderr_unit);
 683       u->s = error_stream ();
 684
 685       u->flags.action = ACTION_WRITE;
 686
 687       u->flags.access = ACCESS_SEQUENTIAL;
 688       u->flags.form = FORM_FORMATTED;
 689       u->flags.status = STATUS_OLD;
 690       u->flags.blank = BLANK_NULL;
 691       u->flags.position = POSITION_ASIS;
 692       u->flags.sign = SIGN_UNSPECIFIED;
 693       u->flags.decimal = DECIMAL_POINT;
 694       u->flags.encoding = ENCODING_DEFAULT;
 695       u->flags.async = ASYNC_NO;
 696       u->flags.round = ROUND_UNSPECIFIED;
 697       u->flags.share = SHARE_UNSPECIFIED;
 698       u->flags.cc = CC_LIST;
 699
 700       u->recl = default_recl;
 701       u->endfile = AT_ENDFILE;
 702
 703       u->filename = strdup (stderr_name);
 704
 705       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
 706                               any kind of exotic formatting to stderr.  */
 707
 708       UNLOCK (&u->lock);
 709     }
 710   /* The default internal units.  */
 711   u = insert_unit (GFC_INTERNAL_UNIT);
 712   UNLOCK (&u->lock);
 713   u = insert_unit (GFC_INTERNAL_UNIT4);
 714   UNLOCK (&u->lock);
 715 }
 716
 717
 718 static int
 719 close_unit_1 (gfc_unit *u, int locked)
 720 {
 721   int i, rc;
 722
 723   if (ASYNC_IO && u->au)
 724     async_close (u->au);
 725
 726   /* If there are previously written bytes from a write with ADVANCE="no"
 727      Reposition the buffer before closing.  */
 728   if (u->previous_nonadvancing_write)
 729     finish_last_advance_record (u);
 730
 731   rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
 732
 733   u->closed = 1;
 734   if (!locked)
 735     LOCK (&unit_lock);
 736
 737   for (i = 0; i < CACHE_SIZE; i++)
 738     if (unit_cache[i] == u)
 739       unit_cache[i] = NULL;
 740
 741   delete_unit (u);
 742
 743   free (u->filename);
 744   u->filename = NULL;
 745
 746   free_format_hash_table (u);
 747   fbuf_destroy (u);
 748
 749   if (u->unit_number <= NEWUNIT_START)
 750     newunit_free (u->unit_number);
 751
 752   if (!locked)
 753     UNLOCK (&u->lock);
 754
 755   /* If there are any threads waiting in find_unit for this unit,
 756      avoid freeing the memory, the last such thread will free it
 757      instead.  */
 758   if (u->waiting == 0)
 759     destroy_unit_mutex (u);
 760
 761   if (!locked)
 762     UNLOCK (&unit_lock);
 763
 764   return rc;
 765 }
 766
 767 void
 768 unlock_unit (gfc_unit *u)
 769 {
 770   NOTE ("unlock_unit = %d", u->unit_number);
 771   UNLOCK (&u->lock);
 772   NOTE ("unlock_unit done");
 773 }
 774
 775 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 776    associated with the stream is freed.  Returns nonzero on I/O error.
 777    Should be called with the u->lock locked. */
 778
 779 int
 780 close_unit (gfc_unit *u)
 781 {
 782   return close_unit_1 (u, 0);
 783 }
 784
 785
 786 /* close_units()-- Delete units on completion.  We just keep deleting
 787    the root of the treap until there is nothing left.
 788    Not sure what to do with locking here.  Some other thread might be
 789    holding some unit's lock and perhaps hold it indefinitely
 790    (e.g. waiting for input from some pipe) and close_units shouldn't
 791    delay the program too much.  */
 792
 793 void
 794 close_units (void)
 795 {
 796   LOCK (&unit_lock);
 797   while (unit_root != NULL)
 798     close_unit_1 (unit_root, 1);
 799   UNLOCK (&unit_lock);
 800
 801   free (newunits);
 802
 803 #ifdef HAVE_FREELOCALE
 804   freelocale (c_locale);
 805 #endif
 806 }
 807
 808
 809 /* High level interface to truncate a file, i.e. flush format buffers,
 810    and generate an error or set some flags.  Just like POSIX
 811    ftruncate, returns 0 on success, -1 on failure.  */
 812
 813 int
 814 unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
 815 {
 816   int ret;
 817
 818   /* Make sure format buffer is flushed.  */
 819   if (u->flags.form == FORM_FORMATTED)
 820     {
 821       if (u->mode == READING)
 822         pos += fbuf_reset (u);
 823       else
 824         fbuf_flush (u, u->mode);
 825     }
 826
 827   /* struncate() should flush the stream buffer if necessary, so don't
 828      bother calling sflush() here.  */
 829   ret = struncate (u->s, pos);
 830
 831   if (ret != 0)
 832     generate_error (common, LIBERROR_OS, NULL);
 833   else
 834     {
 835       u->endfile = AT_ENDFILE;
 836       u->flags.position = POSITION_APPEND;
 837     }
 838
 839   return ret;
 840 }
 841
 842
 843 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 844    name of the associated file, otherwise return the empty string.  The caller
 845    must free memory allocated for the filename string.  */
 846
 847 char *
 848 filename_from_unit (int n)
 849 {
 850   gfc_unit *u;
 851   int c;
 852
 853   /* Find the unit.  */
 854   u = unit_root;
 855   while (u != NULL)
 856     {
 857       c = compare (n, u->unit_number);
 858       if (c < 0)
 859         u = u->left;
 860       if (c > 0)
 861         u = u->right;
 862       if (c == 0)
 863         break;
 864     }
 865
 866   /* Get the filename.  */
 867   if (u != NULL && u->filename != NULL)
 868     return strdup (u->filename);
 869   else
 870     return (char *) NULL;
 871 }
 872
 873 void
 874 finish_last_advance_record (gfc_unit *u)
 875 {
 876
 877   if (u->saved_pos > 0)
 878     fbuf_seek (u, u->saved_pos, SEEK_CUR);
 879
 880   if (!(u->unit_number == options.stdout_unit
 881         || u->unit_number == options.stderr_unit))
 882     {
 883 #ifdef HAVE_CRLF
 884       const int len = 2;
 885 #else
 886       const int len = 1;
 887 #endif
 888       char *p = fbuf_alloc (u, len);
 889       if (!p)
 890         os_error ("Completing record after ADVANCE_NO failed");
 891 #ifdef HAVE_CRLF
 892       *(p++) = '\r';
 893 #endif
 894       *p = '\n';
 895     }
 896
 897   fbuf_flush (u, u->mode);
 898 }
 899
 900
 901 /* Assign a negative number for NEWUNIT in OPEN statements or for
 902    internal units.  */
 903 int
 904 newunit_alloc (void)
 905 {
 906   LOCK (&unit_lock);
 907   if (!newunits)
 908     {
 909       newunits = xcalloc (16, 1);
 910       newunit_size = 16;
 911     }
 912
 913   /* Search for the next available newunit.  */
 914   for (int ii = newunit_lwi; ii < newunit_size; ii++)
 915     {
 916       if (!newunits[ii])
 917         {
 918           newunits[ii] = true;
 919           newunit_lwi = ii + 1;
 920           UNLOCK (&unit_lock);
 921           return -ii + NEWUNIT_START;
 922         }
 923     }
 924
 925   /* Search failed, bump size of array and allocate the first
 926      available unit.  */
 927   int old_size = newunit_size;
 928   newunit_size *= 2;
 929   newunits = xrealloc (newunits, newunit_size);
 930   memset (newunits + old_size, 0, old_size);
 931   newunits[old_size] = true;
 932   newunit_lwi = old_size + 1;
 933     UNLOCK (&unit_lock);
 934   return -old_size + NEWUNIT_START;
 935 }
 936
 937
 938 /* Free a previously allocated newunit= unit number.  unit_lock must
 939    be held when calling.  */
 940
 941 void
 942 newunit_free (int unit)
 943 {
 944   int ind = -unit + NEWUNIT_START;
 945   assert(ind >= 0 && ind < newunit_size);
 946   newunits[ind] = false;
 947   if (ind < newunit_lwi)
 948     newunit_lwi = ind;
 949 }