libgfortran/io/unit.c

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