libgfortran/io/unit.c

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