libgfortran/io/unit.c

   1 /* Copyright (C) 2002-2013 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 gfc_unit *
 379 get_internal_unit (st_parameter_dt *dtp)
 380 {
 381   gfc_unit * iunit;
 382   gfc_offset start_record = 0;
 383
 384   /* Allocate memory for a unit structure.  */
 385
 386   iunit = xcalloc (1, sizeof (gfc_unit));
 387
 388 #ifdef __GTHREAD_MUTEX_INIT
 389   {
 390     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
 391     iunit->lock = tmp;
 392   }
 393 #else
 394   __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
 395 #endif
 396   __gthread_mutex_lock (&iunit->lock);
 397
 398   iunit->recl = dtp->internal_unit_len;
 399
 400   /* For internal units we set the unit number to -1.
 401      Otherwise internal units can be mistaken for a pre-connected unit or
 402      some other file I/O unit.  */
 403   iunit->unit_number = -1;
 404
 405   /* Set up the looping specification from the array descriptor, if any.  */
 406
 407   if (is_array_io (dtp))
 408     {
 409       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
 410       iunit->ls = (array_loop_spec *)
 411         xmalloc (iunit->rank * sizeof (array_loop_spec));
 412       dtp->internal_unit_len *=
 413         init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
 414
 415       start_record *= iunit->recl;
 416     }
 417   else
 418     {
 419       /* If we are not processing an array, adjust the unit record length not
 420          to include trailing blanks for list-formatted reads.  */
 421       if (dtp->u.p.mode == READING && !(dtp->common.flags & IOPARM_DT_HAS_FORMAT))
 422         {
 423           if (dtp->common.unit == 0)
 424             {
 425               dtp->internal_unit_len =
 426                 string_len_trim (dtp->internal_unit_len, dtp->internal_unit);
 427               iunit->recl = dtp->internal_unit_len;
 428             }
 429           else
 430             {
 431               dtp->internal_unit_len =
 432                 string_len_trim_char4 (dtp->internal_unit_len,
 433                                        (const gfc_char4_t*) dtp->internal_unit);
 434               iunit->recl = dtp->internal_unit_len;
 435             }
 436         }
 437     }
 438
 439   /* Set initial values for unit parameters.  */
 440   if (dtp->common.unit)
 441     {
 442       iunit->s = open_internal4 (dtp->internal_unit - start_record,
 443                                  dtp->internal_unit_len, -start_record);
 444       fbuf_init (iunit, 256);
 445     }
 446   else
 447     iunit->s = open_internal (dtp->internal_unit - start_record,
 448                               dtp->internal_unit_len, -start_record);
 449
 450   iunit->bytes_left = iunit->recl;
 451   iunit->last_record=0;
 452   iunit->maxrec=0;
 453   iunit->current_record=0;
 454   iunit->read_bad = 0;
 455   iunit->endfile = NO_ENDFILE;
 456
 457   /* Set flags for the internal unit.  */
 458
 459   iunit->flags.access = ACCESS_SEQUENTIAL;
 460   iunit->flags.action = ACTION_READWRITE;
 461   iunit->flags.blank = BLANK_NULL;
 462   iunit->flags.form = FORM_FORMATTED;
 463   iunit->flags.pad = PAD_YES;
 464   iunit->flags.status = STATUS_UNSPECIFIED;
 465   iunit->flags.sign = SIGN_SUPPRESS;
 466   iunit->flags.decimal = DECIMAL_POINT;
 467   iunit->flags.encoding = ENCODING_DEFAULT;
 468   iunit->flags.async = ASYNC_NO;
 469   iunit->flags.round = ROUND_UNSPECIFIED;
 470
 471   /* Initialize the data transfer parameters.  */
 472
 473   dtp->u.p.advance_status = ADVANCE_YES;
 474   dtp->u.p.seen_dollar = 0;
 475   dtp->u.p.skips = 0;
 476   dtp->u.p.pending_spaces = 0;
 477   dtp->u.p.max_pos = 0;
 478   dtp->u.p.at_eof = 0;
 479
 480   /* This flag tells us the unit is assigned to internal I/O.  */
 481
 482   dtp->u.p.unit_is_internal = 1;
 483
 484   return iunit;
 485 }
 486
 487
 488 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
 489 void
 490 free_internal_unit (st_parameter_dt *dtp)
 491 {
 492   if (!is_internal_unit (dtp))
 493     return;
 494
 495   if (unlikely (is_char4_unit (dtp)))
 496     fbuf_destroy (dtp->u.p.current_unit);
 497
 498   if (dtp->u.p.current_unit != NULL)
 499     {
 500       free (dtp->u.p.current_unit->ls);
 501
 502       free (dtp->u.p.current_unit->s);
 503
 504       destroy_unit_mutex (dtp->u.p.current_unit);
 505     }
 506 }
 507
 508
 509
 510 /* get_unit()-- Returns the unit structure associated with the integer
 511    unit or the internal file.  */
 512
 513 gfc_unit *
 514 get_unit (st_parameter_dt *dtp, int do_create)
 515 {
 516
 517   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 518     return get_internal_unit (dtp);
 519
 520   /* Has to be an external unit.  */
 521
 522   dtp->u.p.unit_is_internal = 0;
 523   dtp->internal_unit_desc = NULL;
 524
 525   return get_external_unit (dtp->common.unit, do_create);
 526 }
 527
 528
 529 /*************************/
 530 /* Initialize everything.  */
 531
 532 void
 533 init_units (void)
 534 {
 535   gfc_unit *u;
 536   unsigned int i;
 537
 538 #ifndef __GTHREAD_MUTEX_INIT
 539   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 540 #endif
 541
 542   if (options.stdin_unit >= 0)
 543     {                           /* STDIN */
 544       u = insert_unit (options.stdin_unit);
 545       u->s = input_stream ();
 546
 547       u->flags.action = ACTION_READ;
 548
 549       u->flags.access = ACCESS_SEQUENTIAL;
 550       u->flags.form = FORM_FORMATTED;
 551       u->flags.status = STATUS_OLD;
 552       u->flags.blank = BLANK_NULL;
 553       u->flags.pad = PAD_YES;
 554       u->flags.position = POSITION_ASIS;
 555       u->flags.sign = SIGN_SUPPRESS;
 556       u->flags.decimal = DECIMAL_POINT;
 557       u->flags.encoding = ENCODING_DEFAULT;
 558       u->flags.async = ASYNC_NO;
 559       u->flags.round = ROUND_UNSPECIFIED;
 560
 561       u->recl = options.default_recl;
 562       u->endfile = NO_ENDFILE;
 563
 564       u->file_len = strlen (stdin_name);
 565       u->file = xmalloc (u->file_len);
 566       memmove (u->file, stdin_name, u->file_len);
 567
 568       fbuf_init (u, 0);
 569
 570       __gthread_mutex_unlock (&u->lock);
 571     }
 572
 573   if (options.stdout_unit >= 0)
 574     {                           /* STDOUT */
 575       u = insert_unit (options.stdout_unit);
 576       u->s = output_stream ();
 577
 578       u->flags.action = ACTION_WRITE;
 579
 580       u->flags.access = ACCESS_SEQUENTIAL;
 581       u->flags.form = FORM_FORMATTED;
 582       u->flags.status = STATUS_OLD;
 583       u->flags.blank = BLANK_NULL;
 584       u->flags.position = POSITION_ASIS;
 585       u->flags.sign = SIGN_SUPPRESS;
 586       u->flags.decimal = DECIMAL_POINT;
 587       u->flags.encoding = ENCODING_DEFAULT;
 588       u->flags.async = ASYNC_NO;
 589       u->flags.round = ROUND_UNSPECIFIED;
 590
 591       u->recl = options.default_recl;
 592       u->endfile = AT_ENDFILE;
 593
 594       u->file_len = strlen (stdout_name);
 595       u->file = xmalloc (u->file_len);
 596       memmove (u->file, stdout_name, u->file_len);
 597
 598       fbuf_init (u, 0);
 599
 600       __gthread_mutex_unlock (&u->lock);
 601     }
 602
 603   if (options.stderr_unit >= 0)
 604     {                           /* STDERR */
 605       u = insert_unit (options.stderr_unit);
 606       u->s = error_stream ();
 607
 608       u->flags.action = ACTION_WRITE;
 609
 610       u->flags.access = ACCESS_SEQUENTIAL;
 611       u->flags.form = FORM_FORMATTED;
 612       u->flags.status = STATUS_OLD;
 613       u->flags.blank = BLANK_NULL;
 614       u->flags.position = POSITION_ASIS;
 615       u->flags.sign = SIGN_SUPPRESS;
 616       u->flags.decimal = DECIMAL_POINT;
 617       u->flags.encoding = ENCODING_DEFAULT;
 618       u->flags.async = ASYNC_NO;
 619       u->flags.round = ROUND_UNSPECIFIED;
 620
 621       u->recl = options.default_recl;
 622       u->endfile = AT_ENDFILE;
 623
 624       u->file_len = strlen (stderr_name);
 625       u->file = xmalloc (u->file_len);
 626       memmove (u->file, stderr_name, u->file_len);
 627
 628       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
 629                               any kind of exotic formatting to stderr.  */
 630
 631       __gthread_mutex_unlock (&u->lock);
 632     }
 633
 634   /* Calculate the maximum file offset in a portable manner.
 635      max will be the largest signed number for the type gfc_offset.
 636      set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
 637   max_offset = 0;
 638   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 639     max_offset = max_offset + ((gfc_offset) 1 << i);
 640 }
 641
 642
 643 static int
 644 close_unit_1 (gfc_unit *u, int locked)
 645 {
 646   int i, rc;
 647
 648   /* If there are previously written bytes from a write with ADVANCE="no"
 649      Reposition the buffer before closing.  */
 650   if (u->previous_nonadvancing_write)
 651     finish_last_advance_record (u);
 652
 653   rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
 654
 655   u->closed = 1;
 656   if (!locked)
 657     __gthread_mutex_lock (&unit_lock);
 658
 659   for (i = 0; i < CACHE_SIZE; i++)
 660     if (unit_cache[i] == u)
 661       unit_cache[i] = NULL;
 662
 663   delete_unit (u);
 664
 665   free (u->file);
 666   u->file = NULL;
 667   u->file_len = 0;
 668
 669   free_format_hash_table (u);
 670   fbuf_destroy (u);
 671
 672   if (!locked)
 673     __gthread_mutex_unlock (&u->lock);
 674
 675   /* If there are any threads waiting in find_unit for this unit,
 676      avoid freeing the memory, the last such thread will free it
 677      instead.  */
 678   if (u->waiting == 0)
 679     destroy_unit_mutex (u);
 680
 681   if (!locked)
 682     __gthread_mutex_unlock (&unit_lock);
 683
 684   return rc;
 685 }
 686
 687 void
 688 unlock_unit (gfc_unit *u)
 689 {
 690   __gthread_mutex_unlock (&u->lock);
 691 }
 692
 693 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 694    associated with the stream is freed.  Returns nonzero on I/O error.
 695    Should be called with the u->lock locked. */
 696
 697 int
 698 close_unit (gfc_unit *u)
 699 {
 700   return close_unit_1 (u, 0);
 701 }
 702
 703
 704 /* close_units()-- Delete units on completion.  We just keep deleting
 705    the root of the treap until there is nothing left.
 706    Not sure what to do with locking here.  Some other thread might be
 707    holding some unit's lock and perhaps hold it indefinitely
 708    (e.g. waiting for input from some pipe) and close_units shouldn't
 709    delay the program too much.  */
 710
 711 void
 712 close_units (void)
 713 {
 714   __gthread_mutex_lock (&unit_lock);
 715   while (unit_root != NULL)
 716     close_unit_1 (unit_root, 1);
 717   __gthread_mutex_unlock (&unit_lock);
 718 }
 719
 720
 721 /* High level interface to truncate a file, i.e. flush format buffers,
 722    and generate an error or set some flags.  Just like POSIX
 723    ftruncate, returns 0 on success, -1 on failure.  */
 724
 725 int
 726 unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
 727 {
 728   int ret;
 729
 730   /* Make sure format buffer is flushed.  */
 731   if (u->flags.form == FORM_FORMATTED)
 732     {
 733       if (u->mode == READING)
 734         pos += fbuf_reset (u);
 735       else
 736         fbuf_flush (u, u->mode);
 737     }
 738
 739   /* struncate() should flush the stream buffer if necessary, so don't
 740      bother calling sflush() here.  */
 741   ret = struncate (u->s, pos);
 742
 743   if (ret != 0)
 744     generate_error (common, LIBERROR_OS, NULL);
 745   else
 746     {
 747       u->endfile = AT_ENDFILE;
 748       u->flags.position = POSITION_APPEND;
 749     }
 750
 751   return ret;
 752 }
 753
 754
 755 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 756    name of the associated file, otherwise return the empty string.  The caller
 757    must free memory allocated for the filename string.  */
 758
 759 char *
 760 filename_from_unit (int n)
 761 {
 762   char *filename;
 763   gfc_unit *u;
 764   int c;
 765
 766   /* Find the unit.  */
 767   u = unit_root;
 768   while (u != NULL)
 769     {
 770       c = compare (n, u->unit_number);
 771       if (c < 0)
 772         u = u->left;
 773       if (c > 0)
 774         u = u->right;
 775       if (c == 0)
 776         break;
 777     }
 778
 779   /* Get the filename.  */
 780   if (u != NULL)
 781     {
 782       filename = (char *) xmalloc (u->file_len + 1);
 783       unpack_filename (filename, u->file, u->file_len);
 784       return filename;
 785     }
 786   else
 787     return (char *) NULL;
 788 }
 789
 790 void
 791 finish_last_advance_record (gfc_unit *u)
 792 {
 793
 794   if (u->saved_pos > 0)
 795     fbuf_seek (u, u->saved_pos, SEEK_CUR);
 796
 797   if (!(u->unit_number == options.stdout_unit
 798         || u->unit_number == options.stderr_unit))
 799     {
 800 #ifdef HAVE_CRLF
 801       const int len = 2;
 802 #else
 803       const int len = 1;
 804 #endif
 805       char *p = fbuf_alloc (u, len);
 806       if (!p)
 807         os_error ("Completing record after ADVANCE_NO failed");
 808 #ifdef HAVE_CRLF
 809       *(p++) = '\r';
 810 #endif
 811       *p = '\n';
 812     }
 813
 814   fbuf_flush (u, u->mode);
 815 }
 816
 817 /* Assign a negative number for NEWUNIT in OPEN statements.  */
 818 GFC_INTEGER_4
 819 get_unique_unit_number (st_parameter_open *opp)
 820 {
 821   GFC_INTEGER_4 num;
 822
 823 #ifdef HAVE_SYNC_FETCH_AND_ADD
 824   num = __sync_fetch_and_add (&next_available_newunit, -1);
 825 #else
 826   __gthread_mutex_lock (&unit_lock);
 827   num = next_available_newunit--;
 828   __gthread_mutex_unlock (&unit_lock);
 829 #endif
 830
 831   /* Do not allow NEWUNIT numbers to wrap.  */
 832   if (num > GFC_FIRST_NEWUNIT)
 833     {
 834       generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
 835       return 0;
 836     }
 837   return num;
 838 }