libgfortran/io/unit.c

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