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