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       free (dtp->u.p.current_unit->ls);
 487
 488       free (dtp->u.p.current_unit->s);
 489
 490       destroy_unit_mutex (dtp->u.p.current_unit);
 491     }
 492 }
 493
 494
 495
 496 /* get_unit()-- Returns the unit structure associated with the integer
 497    unit or the internal file.  */
 498
 499 gfc_unit *
 500 get_unit (st_parameter_dt *dtp, int do_create)
 501 {
 502
 503   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 504     return get_internal_unit (dtp);
 505
 506   /* Has to be an external unit.  */
 507
 508   dtp->u.p.unit_is_internal = 0;
 509   dtp->internal_unit_desc = NULL;
 510
 511   return get_external_unit (dtp->common.unit, do_create);
 512 }
 513
 514
 515 /*************************/
 516 /* Initialize everything.  */
 517
 518 void
 519 init_units (void)
 520 {
 521   gfc_unit *u;
 522   unsigned int i;
 523
 524 #ifndef __GTHREAD_MUTEX_INIT
 525   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 526 #endif
 527
 528   next_available_newunit = GFC_FIRST_NEWUNIT;
 529
 530   if (options.stdin_unit >= 0)
 531     {                           /* STDIN */
 532       u = insert_unit (options.stdin_unit);
 533       u->s = input_stream ();
 534
 535       u->flags.action = ACTION_READ;
 536
 537       u->flags.access = ACCESS_SEQUENTIAL;
 538       u->flags.form = FORM_FORMATTED;
 539       u->flags.status = STATUS_OLD;
 540       u->flags.blank = BLANK_NULL;
 541       u->flags.pad = PAD_YES;
 542       u->flags.position = POSITION_ASIS;
 543       u->flags.sign = SIGN_SUPPRESS;
 544       u->flags.decimal = DECIMAL_POINT;
 545       u->flags.encoding = ENCODING_DEFAULT;
 546       u->flags.async = ASYNC_NO;
 547       u->flags.round = ROUND_COMPATIBLE;
 548
 549       u->recl = options.default_recl;
 550       u->endfile = NO_ENDFILE;
 551
 552       u->file_len = strlen (stdin_name);
 553       u->file = get_mem (u->file_len);
 554       memmove (u->file, stdin_name, u->file_len);
 555
 556       fbuf_init (u, 0);
 557
 558       __gthread_mutex_unlock (&u->lock);
 559     }
 560
 561   if (options.stdout_unit >= 0)
 562     {                           /* STDOUT */
 563       u = insert_unit (options.stdout_unit);
 564       u->s = output_stream ();
 565
 566       u->flags.action = ACTION_WRITE;
 567
 568       u->flags.access = ACCESS_SEQUENTIAL;
 569       u->flags.form = FORM_FORMATTED;
 570       u->flags.status = STATUS_OLD;
 571       u->flags.blank = BLANK_NULL;
 572       u->flags.position = POSITION_ASIS;
 573       u->flags.sign = SIGN_SUPPRESS;
 574       u->flags.decimal = DECIMAL_POINT;
 575       u->flags.encoding = ENCODING_DEFAULT;
 576       u->flags.async = ASYNC_NO;
 577       u->flags.round = ROUND_COMPATIBLE;
 578
 579       u->recl = options.default_recl;
 580       u->endfile = AT_ENDFILE;
 581
 582       u->file_len = strlen (stdout_name);
 583       u->file = get_mem (u->file_len);
 584       memmove (u->file, stdout_name, u->file_len);
 585
 586       fbuf_init (u, 0);
 587
 588       __gthread_mutex_unlock (&u->lock);
 589     }
 590
 591   if (options.stderr_unit >= 0)
 592     {                           /* STDERR */
 593       u = insert_unit (options.stderr_unit);
 594       u->s = error_stream ();
 595
 596       u->flags.action = ACTION_WRITE;
 597
 598       u->flags.access = ACCESS_SEQUENTIAL;
 599       u->flags.form = FORM_FORMATTED;
 600       u->flags.status = STATUS_OLD;
 601       u->flags.blank = BLANK_NULL;
 602       u->flags.position = POSITION_ASIS;
 603       u->flags.sign = SIGN_SUPPRESS;
 604       u->flags.decimal = DECIMAL_POINT;
 605       u->flags.encoding = ENCODING_DEFAULT;
 606       u->flags.async = ASYNC_NO;
 607       u->flags.round = ROUND_COMPATIBLE;
 608
 609       u->recl = options.default_recl;
 610       u->endfile = AT_ENDFILE;
 611
 612       u->file_len = strlen (stderr_name);
 613       u->file = get_mem (u->file_len);
 614       memmove (u->file, stderr_name, u->file_len);
 615
 616       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
 617                               any kind of exotic formatting to stderr.  */
 618
 619       __gthread_mutex_unlock (&u->lock);
 620     }
 621
 622   /* Calculate the maximum file offset in a portable manner.
 623      max will be the largest signed number for the type gfc_offset.
 624      set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
 625   max_offset = 0;
 626   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 627     max_offset = max_offset + ((gfc_offset) 1 << i);
 628 }
 629
 630
 631 static int
 632 close_unit_1 (gfc_unit *u, int locked)
 633 {
 634   int i, rc;
 635
 636   /* If there are previously written bytes from a write with ADVANCE="no"
 637      Reposition the buffer before closing.  */
 638   if (u->previous_nonadvancing_write)
 639     finish_last_advance_record (u);
 640
 641   rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
 642
 643   u->closed = 1;
 644   if (!locked)
 645     __gthread_mutex_lock (&unit_lock);
 646
 647   for (i = 0; i < CACHE_SIZE; i++)
 648     if (unit_cache[i] == u)
 649       unit_cache[i] = NULL;
 650
 651   delete_unit (u);
 652
 653   free (u->file);
 654   u->file = NULL;
 655   u->file_len = 0;
 656
 657   free_format_hash_table (u);
 658   fbuf_destroy (u);
 659
 660   if (!locked)
 661     __gthread_mutex_unlock (&u->lock);
 662
 663   /* If there are any threads waiting in find_unit for this unit,
 664      avoid freeing the memory, the last such thread will free it
 665      instead.  */
 666   if (u->waiting == 0)
 667     destroy_unit_mutex (u);
 668
 669   if (!locked)
 670     __gthread_mutex_unlock (&unit_lock);
 671
 672   return rc;
 673 }
 674
 675 void
 676 unlock_unit (gfc_unit *u)
 677 {
 678   __gthread_mutex_unlock (&u->lock);
 679 }
 680
 681 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 682    associated with the stream is freed.  Returns nonzero on I/O error.
 683    Should be called with the u->lock locked. */
 684
 685 int
 686 close_unit (gfc_unit *u)
 687 {
 688   return close_unit_1 (u, 0);
 689 }
 690
 691
 692 /* close_units()-- Delete units on completion.  We just keep deleting
 693    the root of the treap until there is nothing left.
 694    Not sure what to do with locking here.  Some other thread might be
 695    holding some unit's lock and perhaps hold it indefinitely
 696    (e.g. waiting for input from some pipe) and close_units shouldn't
 697    delay the program too much.  */
 698
 699 void
 700 close_units (void)
 701 {
 702   __gthread_mutex_lock (&unit_lock);
 703   while (unit_root != NULL)
 704     close_unit_1 (unit_root, 1);
 705   __gthread_mutex_unlock (&unit_lock);
 706 }
 707
 708
 709 /* update_position()-- Update the flags position for later use by inquire.  */
 710
 711 void
 712 update_position (gfc_unit *u)
 713 {
 714   /* If unit is not seekable, this makes no sense (and the standard is
 715      silent on this matter), and thus we don't change the position for
 716      a non-seekable file.  */
 717   gfc_offset cur = stell (u->s);
 718   if (cur == -1)
 719     return;
 720   else if (cur == 0)
 721     u->flags.position = POSITION_REWIND;
 722   else if (file_length (u->s) == cur)
 723     u->flags.position = POSITION_APPEND;
 724   else
 725     u->flags.position = POSITION_ASIS;
 726 }
 727
 728
 729 /* High level interface to truncate a file, i.e. flush format buffers,
 730    and generate an error or set some flags.  Just like POSIX
 731    ftruncate, returns 0 on success, -1 on failure.  */
 732
 733 int
 734 unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
 735 {
 736   int ret;
 737
 738   /* Make sure format buffer is flushed.  */
 739   if (u->flags.form == FORM_FORMATTED)
 740     {
 741       if (u->mode == READING)
 742         pos += fbuf_reset (u);
 743       else
 744         fbuf_flush (u, u->mode);
 745     }
 746
 747   /* struncate() should flush the stream buffer if necessary, so don't
 748      bother calling sflush() here.  */
 749   ret = struncate (u->s, pos);
 750
 751   if (ret != 0)
 752     generate_error (common, LIBERROR_OS, NULL);
 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 }