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