libgfortran/io/unit.c

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