libgfortran/io/unit.c

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