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 static void newunit_free (int);
  93
  94 /* Unit numbers assigned with NEWUNIT start from here.  */
  95 #define NEWUNIT_START -10
  96
  97
  98 #define NEWUNIT_STACK_SIZE 16
  99
 100 /* A stack to save previously used newunit-assigned unit numbers to
 101    allow them to be reused without reallocating the gfc_unit structure
 102    which is still in the treap.  */
 103 static gfc_saved_unit newunit_stack[NEWUNIT_STACK_SIZE];
 104 static int newunit_tos = 0; /* Index to Top of Stack.  */
 105
 106
 107 #define CACHE_SIZE 3
 108 static gfc_unit *unit_cache[CACHE_SIZE];
 109 gfc_offset max_offset;
 110 gfc_unit *unit_root;
 111 #ifdef __GTHREAD_MUTEX_INIT
 112 __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
 113 #else
 114 __gthread_mutex_t unit_lock;
 115 #endif
 116
 117 /* We use these filenames for error reporting.  */
 118
 119 static char stdin_name[] = "stdin";
 120 static char stdout_name[] = "stdout";
 121 static char stderr_name[] = "stderr";
 122
 123
 124 #ifdef HAVE_NEWLOCALE
 125 locale_t c_locale;
 126 #else
 127 /* If we don't have POSIX 2008 per-thread locales, we need to use the
 128    traditional setlocale().  To prevent multiple concurrent threads
 129    doing formatted I/O from messing up the locale, we need to store a
 130    global old_locale, and a counter keeping track of how many threads
 131    are currently doing formatted I/O.  The first thread saves the old
 132    locale, and the last one restores it.  */
 133 char *old_locale;
 134 int old_locale_ctr;
 135 #ifdef __GTHREAD_MUTEX_INIT
 136 __gthread_mutex_t old_locale_lock = __GTHREAD_MUTEX_INIT;
 137 #else
 138 __gthread_mutex_t old_locale_lock;
 139 #endif
 140 #endif
 141
 142
 143 /* This implementation is based on Stefan Nilsson's article in the
 144  * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
 145
 146 /* pseudo_random()-- Simple linear congruential pseudorandom number
 147  * generator.  The period of this generator is 44071, which is plenty
 148  * for our purposes.  */
 149
 150 static int
 151 pseudo_random (void)
 152 {
 153   static int x0 = 5341;
 154
 155   x0 = (22611 * x0 + 10) % 44071;
 156   return x0;
 157 }
 158
 159
 160 /* rotate_left()-- Rotate the treap left */
 161
 162 static gfc_unit *
 163 rotate_left (gfc_unit * t)
 164 {
 165   gfc_unit *temp;
 166
 167   temp = t->right;
 168   t->right = t->right->left;
 169   temp->left = t;
 170
 171   return temp;
 172 }
 173
 174
 175 /* rotate_right()-- Rotate the treap right */
 176
 177 static gfc_unit *
 178 rotate_right (gfc_unit * t)
 179 {
 180   gfc_unit *temp;
 181
 182   temp = t->left;
 183   t->left = t->left->right;
 184   temp->right = t;
 185
 186   return temp;
 187 }
 188
 189
 190 static int
 191 compare (int a, int b)
 192 {
 193   if (a < b)
 194     return -1;
 195   if (a > b)
 196     return 1;
 197
 198   return 0;
 199 }
 200
 201
 202 /* insert()-- Recursive insertion function.  Returns the updated treap. */
 203
 204 static gfc_unit *
 205 insert (gfc_unit *new, gfc_unit *t)
 206 {
 207   int c;
 208
 209   if (t == NULL)
 210     return new;
 211
 212   c = compare (new->unit_number, t->unit_number);
 213
 214   if (c < 0)
 215     {
 216       t->left = insert (new, t->left);
 217       if (t->priority < t->left->priority)
 218         t = rotate_right (t);
 219     }
 220
 221   if (c > 0)
 222     {
 223       t->right = insert (new, t->right);
 224       if (t->priority < t->right->priority)
 225         t = rotate_left (t);
 226     }
 227
 228   if (c == 0)
 229     internal_error (NULL, "insert(): Duplicate key found!");
 230
 231   return t;
 232 }
 233
 234
 235 /* insert_unit()-- Create a new node, insert it into the treap.  */
 236
 237 static gfc_unit *
 238 insert_unit (int n)
 239 {
 240   gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
 241   u->unit_number = n;
 242 #ifdef __GTHREAD_MUTEX_INIT
 243   {
 244     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
 245     u->lock = tmp;
 246   }
 247 #else
 248   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
 249 #endif
 250   __gthread_mutex_lock (&u->lock);
 251   u->priority = pseudo_random ();
 252   unit_root = insert (u, unit_root);
 253   return u;
 254 }
 255
 256
 257 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit.  */
 258
 259 static void
 260 destroy_unit_mutex (gfc_unit * u)
 261 {
 262   __gthread_mutex_destroy (&u->lock);
 263   free (u);
 264 }
 265
 266
 267 static gfc_unit *
 268 delete_root (gfc_unit * t)
 269 {
 270   gfc_unit *temp;
 271
 272   if (t->left == NULL)
 273     return t->right;
 274   if (t->right == NULL)
 275     return t->left;
 276
 277   if (t->left->priority > t->right->priority)
 278     {
 279       temp = rotate_right (t);
 280       temp->right = delete_root (t);
 281     }
 282   else
 283     {
 284       temp = rotate_left (t);
 285       temp->left = delete_root (t);
 286     }
 287
 288   return temp;
 289 }
 290
 291
 292 /* delete_treap()-- Delete an element from a tree.  The 'old' value
 293  * does not necessarily have to point to the element to be deleted, it
 294  * must just point to a treap structure with the key to be deleted.
 295  * Returns the new root node of the tree. */
 296
 297 static gfc_unit *
 298 delete_treap (gfc_unit * old, gfc_unit * t)
 299 {
 300   int c;
 301
 302   if (t == NULL)
 303     return NULL;
 304
 305   c = compare (old->unit_number, t->unit_number);
 306
 307   if (c < 0)
 308     t->left = delete_treap (old, t->left);
 309   if (c > 0)
 310     t->right = delete_treap (old, t->right);
 311   if (c == 0)
 312     t = delete_root (t);
 313
 314   return t;
 315 }
 316
 317
 318 /* delete_unit()-- Delete a unit from a tree */
 319
 320 static void
 321 delete_unit (gfc_unit * old)
 322 {
 323   unit_root = delete_treap (old, unit_root);
 324 }
 325
 326
 327 /* get_gfc_unit()-- Given an integer, return a pointer to the unit
 328  * structure.  Returns NULL if the unit does not exist,
 329  * otherwise returns a locked unit. */
 330
 331 static gfc_unit *
 332 get_gfc_unit (int n, int do_create)
 333 {
 334   gfc_unit *p;
 335   int c, created = 0;
 336
 337   __gthread_mutex_lock (&unit_lock);
 338 retry:
 339   for (c = 0; c < CACHE_SIZE; c++)
 340     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
 341       {
 342         p = unit_cache[c];
 343         goto found;
 344       }
 345
 346   p = unit_root;
 347   while (p != NULL)
 348     {
 349       c = compare (n, p->unit_number);
 350       if (c < 0)
 351         p = p->left;
 352       if (c > 0)
 353         p = p->right;
 354       if (c == 0)
 355         break;
 356     }
 357
 358   if (p == NULL && do_create)
 359     {
 360       p = insert_unit (n);
 361       created = 1;
 362     }
 363
 364   if (p != NULL)
 365     {
 366       for (c = 0; c < CACHE_SIZE - 1; c++)
 367         unit_cache[c] = unit_cache[c + 1];
 368
 369       unit_cache[CACHE_SIZE - 1] = p;
 370     }
 371
 372   if (created)
 373     {
 374       /* Newly created units have their lock held already
 375          from insert_unit.  Just unlock UNIT_LOCK and return.  */
 376       __gthread_mutex_unlock (&unit_lock);
 377       return p;
 378     }
 379
 380 found:
 381   if (p != NULL && (p->child_dtio == 0))
 382     {
 383       /* Fast path.  */
 384       if (! __gthread_mutex_trylock (&p->lock))
 385         {
 386           /* assert (p->closed == 0); */
 387           __gthread_mutex_unlock (&unit_lock);
 388           return p;
 389         }
 390
 391       inc_waiting_locked (p);
 392     }
 393
 394
 395   __gthread_mutex_unlock (&unit_lock);
 396
 397   if (p != NULL && (p->child_dtio == 0))
 398     {
 399       __gthread_mutex_lock (&p->lock);
 400       if (p->closed)
 401         {
 402           __gthread_mutex_lock (&unit_lock);
 403           __gthread_mutex_unlock (&p->lock);
 404           if (predec_waiting_locked (p) == 0)
 405             destroy_unit_mutex (p);
 406           goto retry;
 407         }
 408
 409       dec_waiting_unlocked (p);
 410     }
 411   return p;
 412 }
 413
 414
 415 gfc_unit *
 416 find_unit (int n)
 417 {
 418   return get_gfc_unit (n, 0);
 419 }
 420
 421
 422 gfc_unit *
 423 find_or_create_unit (int n)
 424 {
 425   return get_gfc_unit (n, 1);
 426 }
 427
 428
 429 /* Helper function to check rank, stride, format string, and namelist.
 430    This is used for optimization. You can't trim out blanks or shorten
 431    the string if trailing spaces are significant.  */
 432 static bool
 433 is_trim_ok (st_parameter_dt *dtp)
 434 {
 435   /* Check rank and stride.  */
 436   if (dtp->internal_unit_desc)
 437     return false;
 438   /* Format strings can not have 'BZ' or '/'.  */
 439   if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
 440     {
 441       char *p = dtp->format;
 442       off_t i;
 443       if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
 444         return false;
 445       for (i = 0; i < dtp->format_len; i++)
 446         {
 447           if (p[i] == '/') return false;
 448           if (p[i] == 'b' || p[i] == 'B')
 449             if (p[i+1] == 'z' || p[i+1] == 'Z')
 450               return false;
 451         }
 452     }
 453   if (dtp->u.p.ionml) /* A namelist.  */
 454     return false;
 455   return true;
 456 }
 457
 458
 459 gfc_unit *
 460 set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
 461 {
 462   gfc_offset start_record = 0;
 463
 464   iunit->unit_number = dtp->common.unit;
 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
 603   /* If an internal unit number is passed from the parent to the child
 604      it should have been stashed on the newunit_stack ready to be used.
 605      Check for it now and return the internal unit if found.  */
 606   if (newunit_tos && (dtp->common.unit <= NEWUNIT_START)
 607       && (dtp->common.unit == newunit_stack[newunit_tos].unit_number))
 608     {
 609       unit = newunit_stack[newunit_tos--].unit;
 610       return unit;
 611     }
 612
 613   /* Has to be an external unit.  */
 614   dtp->u.p.unit_is_internal = 0;
 615   dtp->internal_unit = NULL;
 616   dtp->internal_unit_desc = NULL;
 617
 618   /* For an external unit with unit number < 0 creating it on the fly
 619      is not allowed, such units must be created with
 620      OPEN(NEWUNIT=...).  */
 621   if (dtp->common.unit < 0)
 622     return get_gfc_unit (dtp->common.unit, 0);
 623
 624   return get_gfc_unit (dtp->common.unit, do_create);
 625 }
 626
 627
 628 /*************************/
 629 /* Initialize everything.  */
 630
 631 void
 632 init_units (void)
 633 {
 634   gfc_unit *u;
 635   unsigned int i;
 636
 637 #ifdef HAVE_NEWLOCALE
 638   c_locale = newlocale (0, "C", 0);
 639 #else
 640 #ifndef __GTHREAD_MUTEX_INIT
 641   __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
 642 #endif
 643 #endif
 644
 645 #ifndef __GTHREAD_MUTEX_INIT
 646   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 647 #endif
 648
 649   if (options.stdin_unit >= 0)
 650     {                           /* STDIN */
 651       u = insert_unit (options.stdin_unit);
 652       u->s = input_stream ();
 653
 654       u->flags.action = ACTION_READ;
 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.pad = PAD_YES;
 661       u->flags.position = POSITION_ASIS;
 662       u->flags.sign = SIGN_UNSPECIFIED;
 663       u->flags.decimal = DECIMAL_POINT;
 664       u->flags.delim = DELIM_UNSPECIFIED;
 665       u->flags.encoding = ENCODING_DEFAULT;
 666       u->flags.async = ASYNC_NO;
 667       u->flags.round = ROUND_UNSPECIFIED;
 668       u->flags.share = SHARE_UNSPECIFIED;
 669       u->flags.cc = CC_LIST;
 670
 671       u->recl = options.default_recl;
 672       u->endfile = NO_ENDFILE;
 673
 674       u->filename = strdup (stdin_name);
 675
 676       fbuf_init (u, 0);
 677
 678       __gthread_mutex_unlock (&u->lock);
 679     }
 680
 681   if (options.stdout_unit >= 0)
 682     {                           /* STDOUT */
 683       u = insert_unit (options.stdout_unit);
 684       u->s = output_stream ();
 685
 686       u->flags.action = ACTION_WRITE;
 687
 688       u->flags.access = ACCESS_SEQUENTIAL;
 689       u->flags.form = FORM_FORMATTED;
 690       u->flags.status = STATUS_OLD;
 691       u->flags.blank = BLANK_NULL;
 692       u->flags.position = POSITION_ASIS;
 693       u->flags.sign = SIGN_UNSPECIFIED;
 694       u->flags.decimal = DECIMAL_POINT;
 695       u->flags.delim = DELIM_UNSPECIFIED;
 696       u->flags.encoding = ENCODING_DEFAULT;
 697       u->flags.async = ASYNC_NO;
 698       u->flags.round = ROUND_UNSPECIFIED;
 699       u->flags.share = SHARE_UNSPECIFIED;
 700       u->flags.cc = CC_LIST;
 701
 702       u->recl = options.default_recl;
 703       u->endfile = AT_ENDFILE;
 704
 705       u->filename = strdup (stdout_name);
 706
 707       fbuf_init (u, 0);
 708
 709       __gthread_mutex_unlock (&u->lock);
 710     }
 711
 712   if (options.stderr_unit >= 0)
 713     {                           /* STDERR */
 714       u = insert_unit (options.stderr_unit);
 715       u->s = error_stream ();
 716
 717       u->flags.action = ACTION_WRITE;
 718
 719       u->flags.access = ACCESS_SEQUENTIAL;
 720       u->flags.form = FORM_FORMATTED;
 721       u->flags.status = STATUS_OLD;
 722       u->flags.blank = BLANK_NULL;
 723       u->flags.position = POSITION_ASIS;
 724       u->flags.sign = SIGN_UNSPECIFIED;
 725       u->flags.decimal = DECIMAL_POINT;
 726       u->flags.encoding = ENCODING_DEFAULT;
 727       u->flags.async = ASYNC_NO;
 728       u->flags.round = ROUND_UNSPECIFIED;
 729       u->flags.share = SHARE_UNSPECIFIED;
 730       u->flags.cc = CC_LIST;
 731
 732       u->recl = options.default_recl;
 733       u->endfile = AT_ENDFILE;
 734
 735       u->filename = strdup (stderr_name);
 736
 737       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
 738                               any kind of exotic formatting to stderr.  */
 739
 740       __gthread_mutex_unlock (&u->lock);
 741     }
 742
 743   /* Calculate the maximum file offset in a portable manner.
 744      max will be the largest signed number for the type gfc_offset.
 745      set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
 746   max_offset = 0;
 747   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 748     max_offset = max_offset + ((gfc_offset) 1 << i);
 749
 750   /* Initialize the newunit stack.  */
 751   memset (newunit_stack, 0, NEWUNIT_STACK_SIZE * sizeof(gfc_saved_unit));
 752   newunit_tos = 0;
 753 }
 754
 755
 756 static int
 757 close_unit_1 (gfc_unit *u, int locked)
 758 {
 759   int i, rc;
 760
 761   /* If there are previously written bytes from a write with ADVANCE="no"
 762      Reposition the buffer before closing.  */
 763   if (u->previous_nonadvancing_write)
 764     finish_last_advance_record (u);
 765
 766   rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
 767
 768   u->closed = 1;
 769   if (!locked)
 770     __gthread_mutex_lock (&unit_lock);
 771
 772   for (i = 0; i < CACHE_SIZE; i++)
 773     if (unit_cache[i] == u)
 774       unit_cache[i] = NULL;
 775
 776   delete_unit (u);
 777
 778   free (u->filename);
 779   u->filename = NULL;
 780
 781   free_format_hash_table (u);
 782   fbuf_destroy (u);
 783
 784   if (u->unit_number <= NEWUNIT_START)
 785     newunit_free (u->unit_number);
 786
 787   if (!locked)
 788     __gthread_mutex_unlock (&u->lock);
 789
 790   /* If there are any threads waiting in find_unit for this unit,
 791      avoid freeing the memory, the last such thread will free it
 792      instead.  */
 793   if (u->waiting == 0)
 794     destroy_unit_mutex (u);
 795
 796   if (!locked)
 797     __gthread_mutex_unlock (&unit_lock);
 798
 799   return rc;
 800 }
 801
 802 void
 803 unlock_unit (gfc_unit *u)
 804 {
 805   __gthread_mutex_unlock (&u->lock);
 806 }
 807
 808 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 809    associated with the stream is freed.  Returns nonzero on I/O error.
 810    Should be called with the u->lock locked. */
 811
 812 int
 813 close_unit (gfc_unit *u)
 814 {
 815   return close_unit_1 (u, 0);
 816 }
 817
 818
 819 /* close_units()-- Delete units on completion.  We just keep deleting
 820    the root of the treap until there is nothing left.
 821    Not sure what to do with locking here.  Some other thread might be
 822    holding some unit's lock and perhaps hold it indefinitely
 823    (e.g. waiting for input from some pipe) and close_units shouldn't
 824    delay the program too much.  */
 825
 826 void
 827 close_units (void)
 828 {
 829   __gthread_mutex_lock (&unit_lock);
 830   while (unit_root != NULL)
 831     close_unit_1 (unit_root, 1);
 832   __gthread_mutex_unlock (&unit_lock);
 833
 834   while (newunit_tos != 0)
 835     if (newunit_stack[newunit_tos].unit)
 836       {
 837         fbuf_destroy (newunit_stack[newunit_tos].unit);
 838         free (newunit_stack[newunit_tos].unit->s);
 839         free (newunit_stack[newunit_tos--].unit);
 840       }
 841
 842   free (newunits);
 843
 844 #ifdef HAVE_FREELOCALE
 845   freelocale (c_locale);
 846 #endif
 847 }
 848
 849
 850 /* High level interface to truncate a file, i.e. flush format buffers,
 851    and generate an error or set some flags.  Just like POSIX
 852    ftruncate, returns 0 on success, -1 on failure.  */
 853
 854 int
 855 unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
 856 {
 857   int ret;
 858
 859   /* Make sure format buffer is flushed.  */
 860   if (u->flags.form == FORM_FORMATTED)
 861     {
 862       if (u->mode == READING)
 863         pos += fbuf_reset (u);
 864       else
 865         fbuf_flush (u, u->mode);
 866     }
 867
 868   /* struncate() should flush the stream buffer if necessary, so don't
 869      bother calling sflush() here.  */
 870   ret = struncate (u->s, pos);
 871
 872   if (ret != 0)
 873     generate_error (common, LIBERROR_OS, NULL);
 874   else
 875     {
 876       u->endfile = AT_ENDFILE;
 877       u->flags.position = POSITION_APPEND;
 878     }
 879
 880   return ret;
 881 }
 882
 883
 884 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 885    name of the associated file, otherwise return the empty string.  The caller
 886    must free memory allocated for the filename string.  */
 887
 888 char *
 889 filename_from_unit (int n)
 890 {
 891   gfc_unit *u;
 892   int c;
 893
 894   /* Find the unit.  */
 895   u = unit_root;
 896   while (u != NULL)
 897     {
 898       c = compare (n, u->unit_number);
 899       if (c < 0)
 900         u = u->left;
 901       if (c > 0)
 902         u = u->right;
 903       if (c == 0)
 904         break;
 905     }
 906
 907   /* Get the filename.  */
 908   if (u != NULL && u->filename != NULL)
 909     return strdup (u->filename);
 910   else
 911     return (char *) NULL;
 912 }
 913
 914 void
 915 finish_last_advance_record (gfc_unit *u)
 916 {
 917
 918   if (u->saved_pos > 0)
 919     fbuf_seek (u, u->saved_pos, SEEK_CUR);
 920
 921   if (!(u->unit_number == options.stdout_unit
 922         || u->unit_number == options.stderr_unit))
 923     {
 924 #ifdef HAVE_CRLF
 925       const int len = 2;
 926 #else
 927       const int len = 1;
 928 #endif
 929       char *p = fbuf_alloc (u, len);
 930       if (!p)
 931         os_error ("Completing record after ADVANCE_NO failed");
 932 #ifdef HAVE_CRLF
 933       *(p++) = '\r';
 934 #endif
 935       *p = '\n';
 936     }
 937
 938   fbuf_flush (u, u->mode);
 939 }
 940
 941
 942 /* Assign a negative number for NEWUNIT in OPEN statements or for
 943    internal units.  */
 944 int
 945 newunit_alloc (void)
 946 {
 947   __gthread_mutex_lock (&unit_lock);
 948   if (!newunits)
 949     {
 950       newunits = xcalloc (16, 1);
 951       newunit_size = 16;
 952     }
 953
 954   /* Search for the next available newunit.  */
 955   for (int ii = newunit_lwi; ii < newunit_size; ii++)
 956     {
 957       if (!newunits[ii])
 958         {
 959           newunits[ii] = true;
 960           newunit_lwi = ii + 1;
 961           __gthread_mutex_unlock (&unit_lock);
 962           return -ii + NEWUNIT_START;
 963         }
 964     }
 965
 966   /* Search failed, bump size of array and allocate the first
 967      available unit.  */
 968   int old_size = newunit_size;
 969   newunit_size *= 2;
 970   newunits = xrealloc (newunits, newunit_size);
 971   memset (newunits + old_size, 0, old_size);
 972   newunits[old_size] = true;
 973   newunit_lwi = old_size + 1;
 974     __gthread_mutex_unlock (&unit_lock);
 975   return -old_size + NEWUNIT_START;
 976 }
 977
 978
 979 /* Free a previously allocated newunit= unit number.  unit_lock must
 980    be held when calling.  */
 981
 982 static void
 983 newunit_free (int unit)
 984 {
 985   int ind = -unit + NEWUNIT_START;
 986   assert(ind >= 0 && ind < newunit_size);
 987   newunits[ind] = false;
 988   if (ind < newunit_lwi)
 989     newunit_lwi = ind;
 990 }