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