libgfortran/io/unit.c

   1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    F2003 I/O support contributed by Jerry DeLisle
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "io.h"
  32 #include <stdlib.h>
  33 #include <string.h>
  34
  35
  36 /* IO locking rules:
  37    UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
  38    Concurrent use of different units should be supported, so
  39    each unit has its own lock, LOCK.
  40    Open should be atomic with its reopening of units and list_read.c
  41    in several places needs find_unit another unit while holding stdin
  42    unit's lock, so it must be possible to acquire UNIT_LOCK while holding
  43    some unit's lock.  Therefore to avoid deadlocks, it is forbidden
  44    to acquire unit's private locks while holding UNIT_LOCK, except
  45    for freshly created units (where no other thread can get at their
  46    address yet) or when using just trylock rather than lock operation.
  47    In addition to unit's private lock each unit has a WAITERS counter
  48    and CLOSED flag.  WAITERS counter must be either only
  49    atomically incremented/decremented in all places (if atomic builtins
  50    are supported), or protected by UNIT_LOCK in all places (otherwise).
  51    CLOSED flag must be always protected by unit's LOCK.
  52    After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
  53    WAITERS must be incremented to avoid concurrent close from freeing
  54    the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
  55    Unit freeing is always done under UNIT_LOCK.  If close_unit sees any
  56    WAITERS, it doesn't free the unit but instead sets the CLOSED flag
  57    and the thread that decrements WAITERS to zero while CLOSED flag is
  58    set is responsible for freeing it (while holding UNIT_LOCK).
  59    flush_all_units operation is iterating over the unit tree with
  60    increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
  61    flush each unit (and therefore needs the unit's LOCK held as well).
  62    To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
  63    remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
  64    unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
  65    the smallest UNIT_NUMBER above the last one flushed.
  66
  67    If find_unit/find_or_create_unit/find_file/get_unit routines return
  68    non-NULL, the returned unit has its private lock locked and when the
  69    caller is done with it, it must call either unlock_unit or close_unit
  70    on it.  unlock_unit or close_unit must be always called only with the
  71    private lock held.  */
  72
  73 /* Subroutines related to units */
  74
  75
  76 #define CACHE_SIZE 3
  77 static gfc_unit *unit_cache[CACHE_SIZE];
  78 gfc_offset max_offset;
  79 gfc_unit *unit_root;
  80 #ifdef __GTHREAD_MUTEX_INIT
  81 __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
  82 #else
  83 __gthread_mutex_t unit_lock;
  84 #endif
  85
  86 /* We use these filenames for error reporting.  */
  87
  88 static char stdin_name[] = "stdin";
  89 static char stdout_name[] = "stdout";
  90 static char stderr_name[] = "stderr";
  91
  92 /* This implementation is based on Stefan Nilsson's article in the
  93  * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
  94
  95 /* pseudo_random()-- Simple linear congruential pseudorandom number
  96  * generator.  The period of this generator is 44071, which is plenty
  97  * for our purposes.  */
  98
  99 static int
 100 pseudo_random (void)
 101 {
 102   static int x0 = 5341;
 103
 104   x0 = (22611 * x0 + 10) % 44071;
 105   return x0;
 106 }
 107
 108
 109 /* rotate_left()-- Rotate the treap left */
 110
 111 static gfc_unit *
 112 rotate_left (gfc_unit * t)
 113 {
 114   gfc_unit *temp;
 115
 116   temp = t->right;
 117   t->right = t->right->left;
 118   temp->left = t;
 119
 120   return temp;
 121 }
 122
 123
 124 /* rotate_right()-- Rotate the treap right */
 125
 126 static gfc_unit *
 127 rotate_right (gfc_unit * t)
 128 {
 129   gfc_unit *temp;
 130
 131   temp = t->left;
 132   t->left = t->left->right;
 133   temp->right = t;
 134
 135   return temp;
 136 }
 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_mem (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.form = FORM_FORMATTED;
 441   iunit->flags.pad = PAD_YES;
 442   iunit->flags.status = STATUS_UNSPECIFIED;
 443   iunit->flags.sign = SIGN_SUPPRESS;
 444   iunit->flags.decimal = DECIMAL_POINT;
 445   iunit->flags.encoding = ENCODING_DEFAULT;
 446   iunit->flags.async = ASYNC_NO;
 447
 448   /* Initialize the data transfer parameters.  */
 449
 450   dtp->u.p.advance_status = ADVANCE_YES;
 451   dtp->u.p.blank_status = BLANK_UNSPECIFIED;
 452   dtp->u.p.seen_dollar = 0;
 453   dtp->u.p.skips = 0;
 454   dtp->u.p.pending_spaces = 0;
 455   dtp->u.p.max_pos = 0;
 456   dtp->u.p.at_eof = 0;
 457
 458   /* This flag tells us the unit is assigned to internal I/O.  */
 459
 460   dtp->u.p.unit_is_internal = 1;
 461
 462   return iunit;
 463 }
 464
 465
 466 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
 467 void
 468 free_internal_unit (st_parameter_dt *dtp)
 469 {
 470   if (!is_internal_unit (dtp))
 471     return;
 472
 473   if (dtp->u.p.current_unit != NULL)
 474     {
 475       if (dtp->u.p.current_unit->ls != NULL)
 476         free_mem (dtp->u.p.current_unit->ls);
 477
 478       if (dtp->u.p.current_unit->s)
 479         free_mem (dtp->u.p.current_unit->s);
 480
 481       destroy_unit_mutex (dtp->u.p.current_unit);
 482     }
 483 }
 484
 485
 486
 487 /* get_unit()-- Returns the unit structure associated with the integer
 488  * unit or the internal file. */
 489
 490 gfc_unit *
 491 get_unit (st_parameter_dt *dtp, int do_create)
 492 {
 493
 494   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 495     return get_internal_unit(dtp);
 496
 497   /* Has to be an external unit */
 498
 499   dtp->u.p.unit_is_internal = 0;
 500   dtp->internal_unit_desc = NULL;
 501
 502   return get_external_unit (dtp->common.unit, do_create);
 503 }
 504
 505
 506 /*************************/
 507 /* Initialize everything */
 508
 509 void
 510 init_units (void)
 511 {
 512   gfc_unit *u;
 513   unsigned int i;
 514
 515 #ifndef __GTHREAD_MUTEX_INIT
 516   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 517 #endif
 518
 519   if (options.stdin_unit >= 0)
 520     {                           /* STDIN */
 521       u = insert_unit (options.stdin_unit);
 522       u->s = input_stream ();
 523
 524       u->flags.action = ACTION_READ;
 525
 526       u->flags.access = ACCESS_SEQUENTIAL;
 527       u->flags.form = FORM_FORMATTED;
 528       u->flags.status = STATUS_OLD;
 529       u->flags.blank = BLANK_NULL;
 530       u->flags.pad = PAD_YES;
 531       u->flags.position = POSITION_ASIS;
 532       u->flags.sign = SIGN_SUPPRESS;
 533       u->flags.decimal = DECIMAL_POINT;
 534       u->flags.encoding = ENCODING_DEFAULT;
 535       u->flags.async = ASYNC_NO;
 536
 537       u->recl = options.default_recl;
 538       u->endfile = NO_ENDFILE;
 539
 540       u->file_len = strlen (stdin_name);
 541       u->file = get_mem (u->file_len);
 542       memmove (u->file, stdin_name, u->file_len);
 543
 544       __gthread_mutex_unlock (&u->lock);
 545     }
 546
 547   if (options.stdout_unit >= 0)
 548     {                           /* STDOUT */
 549       u = insert_unit (options.stdout_unit);
 550       u->s = output_stream ();
 551
 552       u->flags.action = ACTION_WRITE;
 553
 554       u->flags.access = ACCESS_SEQUENTIAL;
 555       u->flags.form = FORM_FORMATTED;
 556       u->flags.status = STATUS_OLD;
 557       u->flags.blank = BLANK_NULL;
 558       u->flags.position = POSITION_ASIS;
 559       u->flags.sign = SIGN_SUPPRESS;
 560       u->flags.decimal = DECIMAL_POINT;
 561       u->flags.encoding = ENCODING_DEFAULT;
 562       u->flags.async = ASYNC_NO;
 563
 564       u->recl = options.default_recl;
 565       u->endfile = AT_ENDFILE;
 566
 567       u->file_len = strlen (stdout_name);
 568       u->file = get_mem (u->file_len);
 569       memmove (u->file, stdout_name, u->file_len);
 570
 571       fbuf_init (u, 0);
 572
 573       __gthread_mutex_unlock (&u->lock);
 574     }
 575
 576   if (options.stderr_unit >= 0)
 577     {                           /* STDERR */
 578       u = insert_unit (options.stderr_unit);
 579       u->s = error_stream ();
 580
 581       u->flags.action = ACTION_WRITE;
 582
 583       u->flags.access = ACCESS_SEQUENTIAL;
 584       u->flags.form = FORM_FORMATTED;
 585       u->flags.status = STATUS_OLD;
 586       u->flags.blank = BLANK_NULL;
 587       u->flags.position = POSITION_ASIS;
 588       u->flags.sign = SIGN_SUPPRESS;
 589       u->flags.decimal = DECIMAL_POINT;
 590       u->flags.encoding = ENCODING_DEFAULT;
 591       u->flags.async = ASYNC_NO;
 592
 593       u->recl = options.default_recl;
 594       u->endfile = AT_ENDFILE;
 595
 596       u->file_len = strlen (stderr_name);
 597       u->file = get_mem (u->file_len);
 598       memmove (u->file, stderr_name, u->file_len);
 599
 600       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
 601                               any kind of exotic formatting to stderr.  */
 602
 603       __gthread_mutex_unlock (&u->lock);
 604     }
 605
 606   /* Calculate the maximum file offset in a portable manner.
 607    * max will be the largest signed number for the type gfc_offset.
 608    *
 609    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 610
 611   max_offset = 0;
 612   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 613     max_offset = max_offset + ((gfc_offset) 1 << i);
 614 }
 615
 616
 617 static int
 618 close_unit_1 (gfc_unit *u, int locked)
 619 {
 620   int i, rc;
 621
 622   /* If there are previously written bytes from a write with ADVANCE="no"
 623      Reposition the buffer before closing.  */
 624   if (u->previous_nonadvancing_write)
 625     finish_last_advance_record (u);
 626
 627   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 628
 629   u->closed = 1;
 630   if (!locked)
 631     __gthread_mutex_lock (&unit_lock);
 632
 633   for (i = 0; i < CACHE_SIZE; i++)
 634     if (unit_cache[i] == u)
 635       unit_cache[i] = NULL;
 636
 637   delete_unit (u);
 638
 639   if (u->file)
 640     free_mem (u->file);
 641   u->file = NULL;
 642   u->file_len = 0;
 643
 644   fbuf_destroy (u);
 645
 646   if (!locked)
 647     __gthread_mutex_unlock (&u->lock);
 648
 649   /* If there are any threads waiting in find_unit for this unit,
 650      avoid freeing the memory, the last such thread will free it
 651      instead.  */
 652   if (u->waiting == 0)
 653     destroy_unit_mutex (u);
 654
 655   if (!locked)
 656     __gthread_mutex_unlock (&unit_lock);
 657
 658   return rc;
 659 }
 660
 661 void
 662 unlock_unit (gfc_unit *u)
 663 {
 664   __gthread_mutex_unlock (&u->lock);
 665 }
 666
 667 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 668  * associated with the stream is freed.  Returns nonzero on I/O error.
 669  * Should be called with the u->lock locked. */
 670
 671 int
 672 close_unit (gfc_unit *u)
 673 {
 674   return close_unit_1 (u, 0);
 675 }
 676
 677
 678 /* close_units()-- Delete units on completion.  We just keep deleting
 679  * the root of the treap until there is nothing left.
 680  * Not sure what to do with locking here.  Some other thread might be
 681  * holding some unit's lock and perhaps hold it indefinitely
 682  * (e.g. waiting for input from some pipe) and close_units shouldn't
 683  * delay the program too much.  */
 684
 685 void
 686 close_units (void)
 687 {
 688   __gthread_mutex_lock (&unit_lock);
 689   while (unit_root != NULL)
 690     close_unit_1 (unit_root, 1);
 691   __gthread_mutex_unlock (&unit_lock);
 692 }
 693
 694
 695 /* update_position()-- Update the flags position for later use by inquire.  */
 696
 697 void
 698 update_position (gfc_unit *u)
 699 {
 700   if (file_position (u->s) == 0)
 701     u->flags.position = POSITION_REWIND;
 702   else if (file_length (u->s) == file_position (u->s))
 703     u->flags.position = POSITION_APPEND;
 704   else
 705     u->flags.position = POSITION_ASIS;
 706 }
 707
 708
 709 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 710    name of the associated file, otherwise return the empty string.  The caller
 711    must free memory allocated for the filename string.  */
 712
 713 char *
 714 filename_from_unit (int n)
 715 {
 716   char *filename;
 717   gfc_unit *u;
 718   int c;
 719
 720   /* Find the unit.  */
 721   u = unit_root;
 722   while (u != NULL)
 723     {
 724       c = compare (n, u->unit_number);
 725       if (c < 0)
 726         u = u->left;
 727       if (c > 0)
 728         u = u->right;
 729       if (c == 0)
 730         break;
 731     }
 732
 733   /* Get the filename.  */
 734   if (u != NULL)
 735     {
 736       filename = (char *) get_mem (u->file_len + 1);
 737       unpack_filename (filename, u->file, u->file_len);
 738       return filename;
 739     }
 740   else
 741     return (char *) NULL;
 742 }
 743
 744 void
 745 finish_last_advance_record (gfc_unit *u)
 746 {
 747
 748   if (u->saved_pos > 0)
 749     fbuf_seek (u, u->saved_pos);
 750
 751   fbuf_flush (u, 1);
 752
 753   if (!(u->unit_number == options.stdout_unit
 754         || u->unit_number == options.stderr_unit))
 755     {
 756       size_t len;
 757
 758       const char crlf[] = "\r\n";
 759 #ifdef HAVE_CRLF
 760       len = 2;
 761 #else
 762       len = 1;
 763 #endif
 764       if (swrite (u->s, &crlf[2-len], &len) != 0)
 765         os_error ("Completing record after ADVANCE_NO failed");
 766     }
 767 }
 768