libgfortran/io/unit.c

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