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