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