libgfortran/io/unix.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   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 95 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 /* Unix stream I/O module */
  28
  29 #include "io.h"
  30 #include <stdlib.h>
  31 #include <limits.h>
  32
  33 #include <unistd.h>
  34 #include <sys/stat.h>
  35 #include <fcntl.h>
  36 #include <assert.h>
  37
  38 #include <string.h>
  39 #include <errno.h>
  40
  41
  42 /* For mingw, we don't identify files by their inode number, but by a
  43    64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
  44 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
  45
  46 #define WIN32_LEAN_AND_MEAN
  47 #include <windows.h>
  48
  49 static uint64_t
  50 id_from_handle (HANDLE hFile)
  51 {
  52   BY_HANDLE_FILE_INFORMATION FileInformation;
  53
  54   if (hFile == INVALID_HANDLE_VALUE)
  55       return 0;
  56
  57   memset (&FileInformation, 0, sizeof(FileInformation));
  58   if (!GetFileInformationByHandle (hFile, &FileInformation))
  59     return 0;
  60
  61   return ((uint64_t) FileInformation.nFileIndexLow)
  62          | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
  63 }
  64
  65
  66 static uint64_t
  67 id_from_path (const char *path)
  68 {
  69   HANDLE hFile;
  70   uint64_t res;
  71
  72   if (!path || !*path || access (path, F_OK))
  73     return (uint64_t) -1;
  74
  75   hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
  76                       FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
  77                       NULL);
  78   res = id_from_handle (hFile);
  79   CloseHandle (hFile);
  80   return res;
  81 }
  82
  83
  84 static uint64_t
  85 id_from_fd (const int fd)
  86 {
  87   return id_from_handle ((HANDLE) _get_osfhandle (fd));
  88 }
  89
  90 #endif
  91
  92 #ifndef PATH_MAX
  93 #define PATH_MAX 1024
  94 #endif
  95
  96 #ifndef PROT_READ
  97 #define PROT_READ 1
  98 #endif
  99
 100 #ifndef PROT_WRITE
 101 #define PROT_WRITE 2
 102 #endif
 103
 104 /* These flags aren't defined on all targets (mingw32), so provide them
 105    here.  */
 106 #ifndef S_IRGRP
 107 #define S_IRGRP 0
 108 #endif
 109
 110 #ifndef S_IWGRP
 111 #define S_IWGRP 0
 112 #endif
 113
 114 #ifndef S_IROTH
 115 #define S_IROTH 0
 116 #endif
 117
 118 #ifndef S_IWOTH
 119 #define S_IWOTH 0
 120 #endif
 121
 122
 123 /* Unix and internal stream I/O module */
 124
 125 static const int BUFFER_SIZE = 8192;
 126
 127 typedef struct
 128 {
 129   stream st;
 130
 131   gfc_offset buffer_offset;     /* File offset of the start of the buffer */
 132   gfc_offset physical_offset;   /* Current physical file offset */
 133   gfc_offset logical_offset;    /* Current logical file offset */
 134   gfc_offset file_length;       /* Length of the file, -1 if not seekable. */
 135
 136   char *buffer;                 /* Pointer to the buffer.  */
 137   int fd;                       /* The POSIX file descriptor.  */
 138
 139   int active;                   /* Length of valid bytes in the buffer */
 140
 141   int prot;
 142   int ndirty;                   /* Dirty bytes starting at buffer_offset */
 143
 144   int special_file;             /* =1 if the fd refers to a special file */
 145 }
 146 unix_stream;
 147
 148
 149 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
 150  * standard descriptors, returning a non-standard descriptor.  If the
 151  * user specifies that system errors should go to standard output,
 152  * then closes standard output, we don't want the system errors to a
 153  * file that has been given file descriptor 1 or 0.  We want to send
 154  * the error to the invalid descriptor. */
 155
 156 static int
 157 fix_fd (int fd)
 158 {
 159 #ifdef HAVE_DUP
 160   int input, output, error;
 161
 162   input = output = error = 0;
 163
 164   /* Unix allocates the lowest descriptors first, so a loop is not
 165      required, but this order is. */
 166   if (fd == STDIN_FILENO)
 167     {
 168       fd = dup (fd);
 169       input = 1;
 170     }
 171   if (fd == STDOUT_FILENO)
 172     {
 173       fd = dup (fd);
 174       output = 1;
 175     }
 176   if (fd == STDERR_FILENO)
 177     {
 178       fd = dup (fd);
 179       error = 1;
 180     }
 181
 182   if (input)
 183     close (STDIN_FILENO);
 184   if (output)
 185     close (STDOUT_FILENO);
 186   if (error)
 187     close (STDERR_FILENO);
 188 #endif
 189
 190   return fd;
 191 }
 192
 193
 194 /* If the stream corresponds to a preconnected unit, we flush the
 195    corresponding C stream.  This is bugware for mixed C-Fortran codes
 196    where the C code doesn't flush I/O before returning.  */
 197 void
 198 flush_if_preconnected (stream * s)
 199 {
 200   int fd;
 201
 202   fd = ((unix_stream *) s)->fd;
 203   if (fd == STDIN_FILENO)
 204     fflush (stdin);
 205   else if (fd == STDOUT_FILENO)
 206     fflush (stdout);
 207   else if (fd == STDERR_FILENO)
 208     fflush (stderr);
 209 }
 210
 211
 212 /* get_oserror()-- Get the most recent operating system error.  For
 213  * unix, this is errno. */
 214
 215 const char *
 216 get_oserror (void)
 217 {
 218   return strerror (errno);
 219 }
 220
 221
 222 /********************************************************************
 223 Raw I/O functions (read, write, seek, tell, truncate, close).
 224
 225 These functions wrap the basic POSIX I/O syscalls. Any deviation in
 226 semantics is a bug, except the following: write restarts in case
 227 of being interrupted by a signal, and as the first argument the
 228 functions take the unix_stream struct rather than an integer file
 229 descriptor. Also, for POSIX read() and write() a nbyte argument larger
 230 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
 231 than size_t as for POSIX read/write.
 232 *********************************************************************/
 233
 234 static int
 235 raw_flush (unix_stream * s  __attribute__ ((unused)))
 236 {
 237   return 0;
 238 }
 239
 240 static ssize_t
 241 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
 242 {
 243   /* For read we can't do I/O in a loop like raw_write does, because
 244      that will break applications that wait for interactive I/O.  */
 245   return read (s->fd, buf, nbyte);
 246 }
 247
 248 static ssize_t
 249 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
 250 {
 251   ssize_t trans, bytes_left;
 252   char *buf_st;
 253
 254   bytes_left = nbyte;
 255   buf_st = (char *) buf;
 256
 257   /* We must write in a loop since some systems don't restart system
 258      calls in case of a signal.  */
 259   while (bytes_left > 0)
 260     {
 261       trans = write (s->fd, buf_st, bytes_left);
 262       if (trans < 0)
 263         {
 264           if (errno == EINTR)
 265             continue;
 266           else
 267             return trans;
 268         }
 269       buf_st += trans;
 270       bytes_left -= trans;
 271     }
 272
 273   return nbyte - bytes_left;
 274 }
 275
 276 static off_t
 277 raw_seek (unix_stream * s, off_t offset, int whence)
 278 {
 279   return lseek (s->fd, offset, whence);
 280 }
 281
 282 static off_t
 283 raw_tell (unix_stream * s)
 284 {
 285   return lseek (s->fd, 0, SEEK_CUR);
 286 }
 287
 288 static int
 289 raw_truncate (unix_stream * s, off_t length)
 290 {
 291 #ifdef HAVE_FTRUNCATE
 292   return ftruncate (s->fd, length);
 293 #elif defined HAVE_CHSIZE
 294   return chsize (s->fd, length);
 295 #else
 296   runtime_error ("required ftruncate or chsize support not present");
 297   return -1;
 298 #endif
 299 }
 300
 301 static int
 302 raw_close (unix_stream * s)
 303 {
 304   int retval;
 305
 306   if (s->fd != STDOUT_FILENO
 307       && s->fd != STDERR_FILENO
 308       && s->fd != STDIN_FILENO)
 309     retval = close (s->fd);
 310   else
 311     retval = 0;
 312   free_mem (s);
 313   return retval;
 314 }
 315
 316 static int
 317 raw_init (unix_stream * s)
 318 {
 319   s->st.read = (void *) raw_read;
 320   s->st.write = (void *) raw_write;
 321   s->st.seek = (void *) raw_seek;
 322   s->st.tell = (void *) raw_tell;
 323   s->st.trunc = (void *) raw_truncate;
 324   s->st.close = (void *) raw_close;
 325   s->st.flush = (void *) raw_flush;
 326
 327   s->buffer = NULL;
 328   return 0;
 329 }
 330
 331
 332 /*********************************************************************
 333 Buffered I/O functions. These functions have the same semantics as the
 334 raw I/O functions above, except that they are buffered in order to
 335 improve performance. The buffer must be flushed when switching from
 336 reading to writing and vice versa.
 337 *********************************************************************/
 338
 339 static int
 340 buf_flush (unix_stream * s)
 341 {
 342   int writelen;
 343
 344   /* Flushing in read mode means discarding read bytes.  */
 345   s->active = 0;
 346
 347   if (s->ndirty == 0)
 348     return 0;
 349
 350   if (s->file_length != -1 && s->physical_offset != s->buffer_offset
 351       && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
 352     return -1;
 353
 354   writelen = raw_write (s, s->buffer, s->ndirty);
 355
 356   s->physical_offset = s->buffer_offset + writelen;
 357
 358   /* Don't increment file_length if the file is non-seekable.  */
 359   if (s->file_length != -1 && s->physical_offset > s->file_length)
 360       s->file_length = s->physical_offset;
 361
 362   s->ndirty -= writelen;
 363   if (s->ndirty != 0)
 364     return -1;
 365
 366   return 0;
 367 }
 368
 369 static ssize_t
 370 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
 371 {
 372   if (s->active == 0)
 373     s->buffer_offset = s->logical_offset;
 374
 375   /* Is the data we want in the buffer?  */
 376   if (s->logical_offset + nbyte <= s->buffer_offset + s->active
 377       && s->buffer_offset <= s->logical_offset)
 378     memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
 379   else
 380     {
 381       /* First copy the active bytes if applicable, then read the rest
 382          either directly or filling the buffer.  */
 383       char *p;
 384       int nread = 0;
 385       ssize_t to_read, did_read;
 386       gfc_offset new_logical;
 387
 388       p = (char *) buf;
 389       if (s->logical_offset >= s->buffer_offset
 390           && s->buffer_offset + s->active >= s->logical_offset)
 391         {
 392           nread = s->active - (s->logical_offset - s->buffer_offset);
 393           memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
 394                   nread);
 395           p += nread;
 396         }
 397       /* At this point we consider all bytes in the buffer discarded.  */
 398       to_read = nbyte - nread;
 399       new_logical = s->logical_offset + nread;
 400       if (s->file_length != -1 && s->physical_offset != new_logical
 401           && lseek (s->fd, new_logical, SEEK_SET) < 0)
 402         return -1;
 403       s->buffer_offset = s->physical_offset = new_logical;
 404       if (to_read <= BUFFER_SIZE/2)
 405         {
 406           did_read = raw_read (s, s->buffer, BUFFER_SIZE);
 407           s->physical_offset += did_read;
 408           s->active = did_read;
 409           did_read = (did_read > to_read) ? to_read : did_read;
 410           memcpy (p, s->buffer, did_read);
 411         }
 412       else
 413         {
 414           did_read = raw_read (s, p, to_read);
 415           s->physical_offset += did_read;
 416           s->active = 0;
 417         }
 418       nbyte = did_read + nread;
 419     }
 420   s->logical_offset += nbyte;
 421   return nbyte;
 422 }
 423
 424 static ssize_t
 425 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
 426 {
 427   if (s->ndirty == 0)
 428     s->buffer_offset = s->logical_offset;
 429
 430   /* Does the data fit into the buffer?  As a special case, if the
 431      buffer is empty and the request is bigger than BUFFER_SIZE/2,
 432      write directly. This avoids the case where the buffer would have
 433      to be flushed at every write.  */
 434   if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
 435       && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
 436       && s->buffer_offset <= s->logical_offset
 437       && s->buffer_offset + s->ndirty >= s->logical_offset)
 438     {
 439       memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
 440       int nd = (s->logical_offset - s->buffer_offset) + nbyte;
 441       if (nd > s->ndirty)
 442         s->ndirty = nd;
 443     }
 444   else
 445     {
 446       /* Flush, and either fill the buffer with the new data, or if
 447          the request is bigger than the buffer size, write directly
 448          bypassing the buffer.  */
 449       buf_flush (s);
 450       if (nbyte <= BUFFER_SIZE/2)
 451         {
 452           memcpy (s->buffer, buf, nbyte);
 453           s->buffer_offset = s->logical_offset;
 454           s->ndirty += nbyte;
 455         }
 456       else
 457         {
 458           if (s->file_length != -1 && s->physical_offset != s->logical_offset
 459               && lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
 460             return -1;
 461           nbyte = raw_write (s, buf, nbyte);
 462           s->physical_offset += nbyte;
 463         }
 464     }
 465   s->logical_offset += nbyte;
 466   /* Don't increment file_length if the file is non-seekable.  */
 467   if (s->file_length != -1 && s->logical_offset > s->file_length)
 468     s->file_length = s->logical_offset;
 469   return nbyte;
 470 }
 471
 472 static off_t
 473 buf_seek (unix_stream * s, off_t offset, int whence)
 474 {
 475   switch (whence)
 476     {
 477     case SEEK_SET:
 478       break;
 479     case SEEK_CUR:
 480       offset += s->logical_offset;
 481       break;
 482     case SEEK_END:
 483       offset += s->file_length;
 484       break;
 485     default:
 486       return -1;
 487     }
 488   if (offset < 0)
 489     {
 490       errno = EINVAL;
 491       return -1;
 492     }
 493   s->logical_offset = offset;
 494   return offset;
 495 }
 496
 497 static off_t
 498 buf_tell (unix_stream * s)
 499 {
 500   return s->logical_offset;
 501 }
 502
 503 static int
 504 buf_truncate (unix_stream * s, off_t length)
 505 {
 506   int r;
 507
 508   if (buf_flush (s) != 0)
 509     return -1;
 510   r = raw_truncate (s, length);
 511   if (r == 0)
 512     s->file_length = length;
 513   return r;
 514 }
 515
 516 static int
 517 buf_close (unix_stream * s)
 518 {
 519   if (buf_flush (s) != 0)
 520     return -1;
 521   free_mem (s->buffer);
 522   return raw_close (s);
 523 }
 524
 525 static int
 526 buf_init (unix_stream * s)
 527 {
 528   s->st.read = (void *) buf_read;
 529   s->st.write = (void *) buf_write;
 530   s->st.seek = (void *) buf_seek;
 531   s->st.tell = (void *) buf_tell;
 532   s->st.trunc = (void *) buf_truncate;
 533   s->st.close = (void *) buf_close;
 534   s->st.flush = (void *) buf_flush;
 535
 536   s->buffer = get_mem (BUFFER_SIZE);
 537   return 0;
 538 }
 539
 540
 541 /*********************************************************************
 542   memory stream functions - These are used for internal files
 543
 544   The idea here is that a single stream structure is created and all
 545   requests must be satisfied from it.  The location and size of the
 546   buffer is the character variable supplied to the READ or WRITE
 547   statement.
 548
 549 *********************************************************************/
 550
 551
 552 char *
 553 mem_alloc_r (stream * strm, int * len)
 554 {
 555   unix_stream * s = (unix_stream *) strm;
 556   gfc_offset n;
 557   gfc_offset where = s->logical_offset;
 558
 559   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 560     return NULL;
 561
 562   n = s->buffer_offset + s->active - where;
 563   if (*len > n)
 564     *len = n;
 565
 566   s->logical_offset = where + *len;
 567
 568   return s->buffer + (where - s->buffer_offset);
 569 }
 570
 571
 572 char *
 573 mem_alloc_w (stream * strm, int * len)
 574 {
 575   unix_stream * s = (unix_stream *) strm;
 576   gfc_offset m;
 577   gfc_offset where = s->logical_offset;
 578
 579   m = where + *len;
 580
 581   if (where < s->buffer_offset)
 582     return NULL;
 583
 584   if (m > s->file_length)
 585     return NULL;
 586
 587   s->logical_offset = m;
 588
 589   return s->buffer + (where - s->buffer_offset);
 590 }
 591
 592
 593 /* Stream read function for internal units.  */
 594
 595 static ssize_t
 596 mem_read (stream * s, void * buf, ssize_t nbytes)
 597 {
 598   void *p;
 599   int nb = nbytes;
 600
 601   p = mem_alloc_r (s, &nb);
 602   if (p)
 603     {
 604       memcpy (buf, p, nb);
 605       return (ssize_t) nb;
 606     }
 607   else
 608     return 0;
 609 }
 610
 611
 612 /* Stream write function for internal units. This is not actually used
 613    at the moment, as all internal IO is formatted and the formatted IO
 614    routines use mem_alloc_w_at.  */
 615
 616 static ssize_t
 617 mem_write (stream * s, const void * buf, ssize_t nbytes)
 618 {
 619   void *p;
 620   int nb = nbytes;
 621
 622   p = mem_alloc_w (s, &nb);
 623   if (p)
 624     {
 625       memcpy (p, buf, nb);
 626       return (ssize_t) nb;
 627     }
 628   else
 629     return 0;
 630 }
 631
 632
 633 static off_t
 634 mem_seek (stream * strm, off_t offset, int whence)
 635 {
 636   unix_stream * s = (unix_stream *) strm;
 637   switch (whence)
 638     {
 639     case SEEK_SET:
 640       break;
 641     case SEEK_CUR:
 642       offset += s->logical_offset;
 643       break;
 644     case SEEK_END:
 645       offset += s->file_length;
 646       break;
 647     default:
 648       return -1;
 649     }
 650
 651   /* Note that for internal array I/O it's actually possible to have a
 652      negative offset, so don't check for that.  */
 653   if (offset > s->file_length)
 654     {
 655       errno = EINVAL;
 656       return -1;
 657     }
 658
 659   s->logical_offset = offset;
 660
 661   /* Returning < 0 is the error indicator for sseek(), so return 0 if
 662      offset is negative.  Thus if the return value is 0, the caller
 663      has to use stell() to get the real value of logical_offset.  */
 664   if (offset >= 0)
 665     return offset;
 666   return 0;
 667 }
 668
 669
 670 static off_t
 671 mem_tell (stream * s)
 672 {
 673   return ((unix_stream *)s)->logical_offset;
 674 }
 675
 676
 677 static int
 678 mem_truncate (unix_stream * s __attribute__ ((unused)),
 679               off_t length __attribute__ ((unused)))
 680 {
 681   return 0;
 682 }
 683
 684
 685 static int
 686 mem_flush (unix_stream * s __attribute__ ((unused)))
 687 {
 688   return 0;
 689 }
 690
 691
 692 static int
 693 mem_close (unix_stream * s)
 694 {
 695   if (s != NULL)
 696     free_mem (s);
 697
 698   return 0;
 699 }
 700
 701
 702 /*********************************************************************
 703   Public functions -- A reimplementation of this module needs to
 704   define functional equivalents of the following.
 705 *********************************************************************/
 706
 707 /* empty_internal_buffer()-- Zero the buffer of Internal file */
 708
 709 void
 710 empty_internal_buffer(stream *strm)
 711 {
 712   unix_stream * s = (unix_stream *) strm;
 713   memset(s->buffer, ' ', s->file_length);
 714 }
 715
 716 /* open_internal()-- Returns a stream structure from an internal file */
 717
 718 stream *
 719 open_internal (char *base, int length, gfc_offset offset)
 720 {
 721   unix_stream *s;
 722
 723   s = get_mem (sizeof (unix_stream));
 724   memset (s, '\0', sizeof (unix_stream));
 725
 726   s->buffer = base;
 727   s->buffer_offset = offset;
 728
 729   s->logical_offset = 0;
 730   s->active = s->file_length = length;
 731
 732   s->st.close = (void *) mem_close;
 733   s->st.seek = (void *) mem_seek;
 734   s->st.tell = (void *) mem_tell;
 735   s->st.trunc = (void *) mem_truncate;
 736   s->st.read = (void *) mem_read;
 737   s->st.write = (void *) mem_write;
 738   s->st.flush = (void *) mem_flush;
 739
 740   return (stream *) s;
 741 }
 742
 743
 744 /* fd_to_stream()-- Given an open file descriptor, build a stream
 745  * around it. */
 746
 747 static stream *
 748 fd_to_stream (int fd, int prot)
 749 {
 750   struct stat statbuf;
 751   unix_stream *s;
 752
 753   s = get_mem (sizeof (unix_stream));
 754   memset (s, '\0', sizeof (unix_stream));
 755
 756   s->fd = fd;
 757   s->buffer_offset = 0;
 758   s->physical_offset = 0;
 759   s->logical_offset = 0;
 760   s->prot = prot;
 761
 762   /* Get the current length of the file. */
 763
 764   fstat (fd, &statbuf);
 765
 766   if (lseek (fd, 0, SEEK_CUR) == (off_t) -1)
 767     s->file_length = -1;
 768   else
 769     s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
 770
 771   s->special_file = !S_ISREG (statbuf.st_mode);
 772
 773   if (isatty (s->fd) || options.all_unbuffered
 774       ||(options.unbuffered_preconnected &&
 775          (s->fd == STDIN_FILENO
 776           || s->fd == STDOUT_FILENO
 777           || s->fd == STDERR_FILENO)))
 778     raw_init (s);
 779   else
 780     buf_init (s);
 781
 782   return (stream *) s;
 783 }
 784
 785
 786 /* Given the Fortran unit number, convert it to a C file descriptor.  */
 787
 788 int
 789 unit_to_fd (int unit)
 790 {
 791   gfc_unit *us;
 792   int fd;
 793
 794   us = find_unit (unit);
 795   if (us == NULL)
 796     return -1;
 797
 798   fd = ((unix_stream *) us->s)->fd;
 799   unlock_unit (us);
 800   return fd;
 801 }
 802
 803
 804 /* unpack_filename()-- Given a fortran string and a pointer to a
 805  * buffer that is PATH_MAX characters, convert the fortran string to a
 806  * C string in the buffer.  Returns nonzero if this is not possible.  */
 807
 808 int
 809 unpack_filename (char *cstring, const char *fstring, int len)
 810 {
 811   len = fstrlen (fstring, len);
 812   if (len >= PATH_MAX)
 813     return 1;
 814
 815   memmove (cstring, fstring, len);
 816   cstring[len] = '\0';
 817
 818   return 0;
 819 }
 820
 821
 822 /* tempfile()-- Generate a temporary filename for a scratch file and
 823  * open it.  mkstemp() opens the file for reading and writing, but the
 824  * library mode prevents anything that is not allowed.  The descriptor
 825  * is returned, which is -1 on error.  The template is pointed to by
 826  * opp->file, which is copied into the unit structure
 827  * and freed later. */
 828
 829 static int
 830 tempfile (st_parameter_open *opp)
 831 {
 832   const char *tempdir;
 833   char *template;
 834   int fd;
 835
 836   tempdir = getenv ("GFORTRAN_TMPDIR");
 837   if (tempdir == NULL)
 838     tempdir = getenv ("TMP");
 839   if (tempdir == NULL)
 840     tempdir = getenv ("TEMP");
 841   if (tempdir == NULL)
 842     tempdir = DEFAULT_TEMPDIR;
 843
 844   template = get_mem (strlen (tempdir) + 20);
 845
 846   sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
 847
 848 #ifdef HAVE_MKSTEMP
 849
 850   fd = mkstemp (template);
 851
 852 #else /* HAVE_MKSTEMP */
 853
 854   if (mktemp (template))
 855     do
 856 #if defined(HAVE_CRLF) && defined(O_BINARY)
 857       fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
 858                  S_IREAD | S_IWRITE);
 859 #else
 860       fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
 861 #endif
 862     while (!(fd == -1 && errno == EEXIST) && mktemp (template));
 863   else
 864     fd = -1;
 865
 866 #endif /* HAVE_MKSTEMP */
 867
 868   if (fd < 0)
 869     free_mem (template);
 870   else
 871     {
 872       opp->file = template;
 873       opp->file_len = strlen (template);        /* Don't include trailing nul */
 874     }
 875
 876   return fd;
 877 }
 878
 879
 880 /* regular_file()-- Open a regular file.
 881  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
 882  * unless an error occurs.
 883  * Returns the descriptor, which is less than zero on error. */
 884
 885 static int
 886 regular_file (st_parameter_open *opp, unit_flags *flags)
 887 {
 888   char path[PATH_MAX + 1];
 889   int mode;
 890   int rwflag;
 891   int crflag;
 892   int fd;
 893
 894   if (unpack_filename (path, opp->file, opp->file_len))
 895     {
 896       errno = ENOENT;           /* Fake an OS error */
 897       return -1;
 898     }
 899
 900   rwflag = 0;
 901
 902   switch (flags->action)
 903     {
 904     case ACTION_READ:
 905       rwflag = O_RDONLY;
 906       break;
 907
 908     case ACTION_WRITE:
 909       rwflag = O_WRONLY;
 910       break;
 911
 912     case ACTION_READWRITE:
 913     case ACTION_UNSPECIFIED:
 914       rwflag = O_RDWR;
 915       break;
 916
 917     default:
 918       internal_error (&opp->common, "regular_file(): Bad action");
 919     }
 920
 921   switch (flags->status)
 922     {
 923     case STATUS_NEW:
 924       crflag = O_CREAT | O_EXCL;
 925       break;
 926
 927     case STATUS_OLD:            /* open will fail if the file does not exist*/
 928       crflag = 0;
 929       break;
 930
 931     case STATUS_UNKNOWN:
 932     case STATUS_SCRATCH:
 933       crflag = O_CREAT;
 934       break;
 935
 936     case STATUS_REPLACE:
 937       crflag = O_CREAT | O_TRUNC;
 938       break;
 939
 940     default:
 941       internal_error (&opp->common, "regular_file(): Bad status");
 942     }
 943
 944   /* rwflag |= O_LARGEFILE; */
 945
 946 #if defined(HAVE_CRLF) && defined(O_BINARY)
 947   crflag |= O_BINARY;
 948 #endif
 949
 950   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
 951   fd = open (path, rwflag | crflag, mode);
 952   if (flags->action != ACTION_UNSPECIFIED)
 953     return fd;
 954
 955   if (fd >= 0)
 956     {
 957       flags->action = ACTION_READWRITE;
 958       return fd;
 959     }
 960   if (errno != EACCES && errno != EROFS)
 961      return fd;
 962
 963   /* retry for read-only access */
 964   rwflag = O_RDONLY;
 965   fd = open (path, rwflag | crflag, mode);
 966   if (fd >=0)
 967     {
 968       flags->action = ACTION_READ;
 969       return fd;                /* success */
 970     }
 971
 972   if (errno != EACCES)
 973     return fd;                  /* failure */
 974
 975   /* retry for write-only access */
 976   rwflag = O_WRONLY;
 977   fd = open (path, rwflag | crflag, mode);
 978   if (fd >=0)
 979     {
 980       flags->action = ACTION_WRITE;
 981       return fd;                /* success */
 982     }
 983   return fd;                    /* failure */
 984 }
 985
 986
 987 /* open_external()-- Open an external file, unix specific version.
 988  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
 989  * Returns NULL on operating system error. */
 990
 991 stream *
 992 open_external (st_parameter_open *opp, unit_flags *flags)
 993 {
 994   int fd, prot;
 995
 996   if (flags->status == STATUS_SCRATCH)
 997     {
 998       fd = tempfile (opp);
 999       if (flags->action == ACTION_UNSPECIFIED)
1000         flags->action = ACTION_READWRITE;
1001
1002 #if HAVE_UNLINK_OPEN_FILE
1003       /* We can unlink scratch files now and it will go away when closed. */
1004       if (fd >= 0)
1005         unlink (opp->file);
1006 #endif
1007     }
1008   else
1009     {
1010       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1011        * if it succeeds */
1012       fd = regular_file (opp, flags);
1013     }
1014
1015   if (fd < 0)
1016     return NULL;
1017   fd = fix_fd (fd);
1018
1019   switch (flags->action)
1020     {
1021     case ACTION_READ:
1022       prot = PROT_READ;
1023       break;
1024
1025     case ACTION_WRITE:
1026       prot = PROT_WRITE;
1027       break;
1028
1029     case ACTION_READWRITE:
1030       prot = PROT_READ | PROT_WRITE;
1031       break;
1032
1033     default:
1034       internal_error (&opp->common, "open_external(): Bad action");
1035     }
1036
1037   return fd_to_stream (fd, prot);
1038 }
1039
1040
1041 /* input_stream()-- Return a stream pointer to the default input stream.
1042  * Called on initialization. */
1043
1044 stream *
1045 input_stream (void)
1046 {
1047   return fd_to_stream (STDIN_FILENO, PROT_READ);
1048 }
1049
1050
1051 /* output_stream()-- Return a stream pointer to the default output stream.
1052  * Called on initialization. */
1053
1054 stream *
1055 output_stream (void)
1056 {
1057   stream * s;
1058
1059 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1060   setmode (STDOUT_FILENO, O_BINARY);
1061 #endif
1062
1063   s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1064   return s;
1065 }
1066
1067
1068 /* error_stream()-- Return a stream pointer to the default error stream.
1069  * Called on initialization. */
1070
1071 stream *
1072 error_stream (void)
1073 {
1074   stream * s;
1075
1076 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1077   setmode (STDERR_FILENO, O_BINARY);
1078 #endif
1079
1080   s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1081   return s;
1082 }
1083
1084
1085 /* st_vprintf()-- vprintf function for error output.  To avoid buffer
1086    overruns, we limit the length of the buffer to ST_VPRINTF_SIZE.  2k
1087    is big enough to completely fill a 80x25 terminal, so it shuld be
1088    OK.  We use a direct write() because it is simpler and least likely
1089    to be clobbered by memory corruption.  Writing an error message
1090    longer than that is an error.  */
1091
1092 #define ST_VPRINTF_SIZE 2048
1093
1094 int
1095 st_vprintf (const char *format, va_list ap)
1096 {
1097   static char buffer[ST_VPRINTF_SIZE];
1098   int written;
1099   int fd;
1100
1101   fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1102 #ifdef HAVE_VSNPRINTF
1103   written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1104 #else
1105   written = vsprintf(buffer, format, ap);
1106
1107   if (written >= ST_VPRINTF_SIZE-1)
1108     {
1109       /* The error message was longer than our buffer.  Ouch.  Because
1110          we may have messed up things badly, report the error and
1111          quit.  */
1112 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1113       write (fd, buffer, ST_VPRINTF_SIZE-1);
1114       write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1115       sys_exit(2);
1116 #undef ERROR_MESSAGE
1117
1118     }
1119 #endif
1120
1121   written = write (fd, buffer, written);
1122   return written;
1123 }
1124
1125 /* st_printf()-- printf() function for error output.  This just calls
1126    st_vprintf() to do the actual work.  */
1127
1128 int
1129 st_printf (const char *format, ...)
1130 {
1131   int written;
1132   va_list ap;
1133   va_start (ap, format);
1134   written = st_vprintf(format, ap);
1135   va_end (ap);
1136   return written;
1137 }
1138
1139
1140 /* compare_file_filename()-- Given an open stream and a fortran string
1141  * that is a filename, figure out if the file is the same as the
1142  * filename. */
1143
1144 int
1145 compare_file_filename (gfc_unit *u, const char *name, int len)
1146 {
1147   char path[PATH_MAX + 1];
1148   struct stat st1;
1149 #ifdef HAVE_WORKING_STAT
1150   struct stat st2;
1151 #else
1152 # ifdef __MINGW32__
1153   uint64_t id1, id2;
1154 # endif
1155 #endif
1156
1157   if (unpack_filename (path, name, len))
1158     return 0;                   /* Can't be the same */
1159
1160   /* If the filename doesn't exist, then there is no match with the
1161    * existing file. */
1162
1163   if (stat (path, &st1) < 0)
1164     return 0;
1165
1166 #ifdef HAVE_WORKING_STAT
1167   fstat (((unix_stream *) (u->s))->fd, &st2);
1168   return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1169 #else
1170
1171 # ifdef __MINGW32__
1172   /* We try to match files by a unique ID.  On some filesystems (network
1173      fs and FAT), we can't generate this unique ID, and will simply compare
1174      filenames.  */
1175   id1 = id_from_path (path);
1176   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1177   if (id1 || id2)
1178     return (id1 == id2);
1179 # endif
1180
1181   if (len != u->file_len)
1182     return 0;
1183   return (memcmp(path, u->file, len) == 0);
1184 #endif
1185 }
1186
1187
1188 #ifdef HAVE_WORKING_STAT
1189 # define FIND_FILE0_DECL struct stat *st
1190 # define FIND_FILE0_ARGS st
1191 #else
1192 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1193 # define FIND_FILE0_ARGS id, file, file_len
1194 #endif
1195
1196 /* find_file0()-- Recursive work function for find_file() */
1197
1198 static gfc_unit *
1199 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1200 {
1201   gfc_unit *v;
1202 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1203   uint64_t id1;
1204 #endif
1205
1206   if (u == NULL)
1207     return NULL;
1208
1209 #ifdef HAVE_WORKING_STAT
1210   if (u->s != NULL
1211       && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1212       st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1213     return u;
1214 #else
1215 # ifdef __MINGW32__
1216   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1217     {
1218       if (id == id1)
1219         return u;
1220     }
1221   else
1222 # endif
1223     if (compare_string (u->file_len, u->file, file_len, file) == 0)
1224       return u;
1225 #endif
1226
1227   v = find_file0 (u->left, FIND_FILE0_ARGS);
1228   if (v != NULL)
1229     return v;
1230
1231   v = find_file0 (u->right, FIND_FILE0_ARGS);
1232   if (v != NULL)
1233     return v;
1234
1235   return NULL;
1236 }
1237
1238
1239 /* find_file()-- Take the current filename and see if there is a unit
1240  * that has the file already open.  Returns a pointer to the unit if so. */
1241
1242 gfc_unit *
1243 find_file (const char *file, gfc_charlen_type file_len)
1244 {
1245   char path[PATH_MAX + 1];
1246   struct stat st[2];
1247   gfc_unit *u;
1248   uint64_t id;
1249
1250   if (unpack_filename (path, file, file_len))
1251     return NULL;
1252
1253   if (stat (path, &st[0]) < 0)
1254     return NULL;
1255
1256 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1257   id = id_from_path (path);
1258 #else
1259   id = 0;
1260 #endif
1261
1262   __gthread_mutex_lock (&unit_lock);
1263 retry:
1264   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1265   if (u != NULL)
1266     {
1267       /* Fast path.  */
1268       if (! __gthread_mutex_trylock (&u->lock))
1269         {
1270           /* assert (u->closed == 0); */
1271           __gthread_mutex_unlock (&unit_lock);
1272           return u;
1273         }
1274
1275       inc_waiting_locked (u);
1276     }
1277   __gthread_mutex_unlock (&unit_lock);
1278   if (u != NULL)
1279     {
1280       __gthread_mutex_lock (&u->lock);
1281       if (u->closed)
1282         {
1283           __gthread_mutex_lock (&unit_lock);
1284           __gthread_mutex_unlock (&u->lock);
1285           if (predec_waiting_locked (u) == 0)
1286             free_mem (u);
1287           goto retry;
1288         }
1289
1290       dec_waiting_unlocked (u);
1291     }
1292   return u;
1293 }
1294
1295 static gfc_unit *
1296 flush_all_units_1 (gfc_unit *u, int min_unit)
1297 {
1298   while (u != NULL)
1299     {
1300       if (u->unit_number > min_unit)
1301         {
1302           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1303           if (r != NULL)
1304             return r;
1305         }
1306       if (u->unit_number >= min_unit)
1307         {
1308           if (__gthread_mutex_trylock (&u->lock))
1309             return u;
1310           if (u->s)
1311             sflush (u->s);
1312           __gthread_mutex_unlock (&u->lock);
1313         }
1314       u = u->right;
1315     }
1316   return NULL;
1317 }
1318
1319 void
1320 flush_all_units (void)
1321 {
1322   gfc_unit *u;
1323   int min_unit = 0;
1324
1325   __gthread_mutex_lock (&unit_lock);
1326   do
1327     {
1328       u = flush_all_units_1 (unit_root, min_unit);
1329       if (u != NULL)
1330         inc_waiting_locked (u);
1331       __gthread_mutex_unlock (&unit_lock);
1332       if (u == NULL)
1333         return;
1334
1335       __gthread_mutex_lock (&u->lock);
1336
1337       min_unit = u->unit_number + 1;
1338
1339       if (u->closed == 0)
1340         {
1341           sflush (u->s);
1342           __gthread_mutex_lock (&unit_lock);
1343           __gthread_mutex_unlock (&u->lock);
1344           (void) predec_waiting_locked (u);
1345         }
1346       else
1347         {
1348           __gthread_mutex_lock (&unit_lock);
1349           __gthread_mutex_unlock (&u->lock);
1350           if (predec_waiting_locked (u) == 0)
1351             free_mem (u);
1352         }
1353     }
1354   while (1);
1355 }
1356
1357
1358 /* delete_file()-- Given a unit structure, delete the file associated
1359  * with the unit.  Returns nonzero if something went wrong. */
1360
1361 int
1362 delete_file (gfc_unit * u)
1363 {
1364   char path[PATH_MAX + 1];
1365
1366   if (unpack_filename (path, u->file, u->file_len))
1367     {                           /* Shouldn't be possible */
1368       errno = ENOENT;
1369       return 1;
1370     }
1371
1372   return unlink (path);
1373 }
1374
1375
1376 /* file_exists()-- Returns nonzero if the current filename exists on
1377  * the system */
1378
1379 int
1380 file_exists (const char *file, gfc_charlen_type file_len)
1381 {
1382   char path[PATH_MAX + 1];
1383   struct stat statbuf;
1384
1385   if (unpack_filename (path, file, file_len))
1386     return 0;
1387
1388   if (stat (path, &statbuf) < 0)
1389     return 0;
1390
1391   return 1;
1392 }
1393
1394
1395
1396 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1397
1398 /* inquire_sequential()-- Given a fortran string, determine if the
1399  * file is suitable for sequential access.  Returns a C-style
1400  * string. */
1401
1402 const char *
1403 inquire_sequential (const char *string, int len)
1404 {
1405   char path[PATH_MAX + 1];
1406   struct stat statbuf;
1407
1408   if (string == NULL ||
1409       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1410     return unknown;
1411
1412   if (S_ISREG (statbuf.st_mode) ||
1413       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1414     return unknown;
1415
1416   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1417     return no;
1418
1419   return unknown;
1420 }
1421
1422
1423 /* inquire_direct()-- Given a fortran string, determine if the file is
1424  * suitable for direct access.  Returns a C-style string. */
1425
1426 const char *
1427 inquire_direct (const char *string, int len)
1428 {
1429   char path[PATH_MAX + 1];
1430   struct stat statbuf;
1431
1432   if (string == NULL ||
1433       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1434     return unknown;
1435
1436   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1437     return unknown;
1438
1439   if (S_ISDIR (statbuf.st_mode) ||
1440       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1441     return no;
1442
1443   return unknown;
1444 }
1445
1446
1447 /* inquire_formatted()-- Given a fortran string, determine if the file
1448  * is suitable for formatted form.  Returns a C-style string. */
1449
1450 const char *
1451 inquire_formatted (const char *string, int len)
1452 {
1453   char path[PATH_MAX + 1];
1454   struct stat statbuf;
1455
1456   if (string == NULL ||
1457       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1458     return unknown;
1459
1460   if (S_ISREG (statbuf.st_mode) ||
1461       S_ISBLK (statbuf.st_mode) ||
1462       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1463     return unknown;
1464
1465   if (S_ISDIR (statbuf.st_mode))
1466     return no;
1467
1468   return unknown;
1469 }
1470
1471
1472 /* inquire_unformatted()-- Given a fortran string, determine if the file
1473  * is suitable for unformatted form.  Returns a C-style string. */
1474
1475 const char *
1476 inquire_unformatted (const char *string, int len)
1477 {
1478   return inquire_formatted (string, len);
1479 }
1480
1481
1482 #ifndef HAVE_ACCESS
1483
1484 #ifndef W_OK
1485 #define W_OK 2
1486 #endif
1487
1488 #ifndef R_OK
1489 #define R_OK 4
1490 #endif
1491
1492 /* Fallback implementation of access() on systems that don't have it.
1493    Only modes R_OK and W_OK are used in this file.  */
1494
1495 static int
1496 fallback_access (const char *path, int mode)
1497 {
1498   if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1499     return -1;
1500
1501   if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1502     return -1;
1503
1504   return 0;
1505 }
1506
1507 #undef access
1508 #define access fallback_access
1509 #endif
1510
1511
1512 /* inquire_access()-- Given a fortran string, determine if the file is
1513  * suitable for access. */
1514
1515 static const char *
1516 inquire_access (const char *string, int len, int mode)
1517 {
1518   char path[PATH_MAX + 1];
1519
1520   if (string == NULL || unpack_filename (path, string, len) ||
1521       access (path, mode) < 0)
1522     return no;
1523
1524   return yes;
1525 }
1526
1527
1528 /* inquire_read()-- Given a fortran string, determine if the file is
1529  * suitable for READ access. */
1530
1531 const char *
1532 inquire_read (const char *string, int len)
1533 {
1534   return inquire_access (string, len, R_OK);
1535 }
1536
1537
1538 /* inquire_write()-- Given a fortran string, determine if the file is
1539  * suitable for READ access. */
1540
1541 const char *
1542 inquire_write (const char *string, int len)
1543 {
1544   return inquire_access (string, len, W_OK);
1545 }
1546
1547
1548 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1549  * suitable for read and write access. */
1550
1551 const char *
1552 inquire_readwrite (const char *string, int len)
1553 {
1554   return inquire_access (string, len, R_OK | W_OK);
1555 }
1556
1557
1558 /* file_length()-- Return the file length in bytes, -1 if unknown */
1559
1560 gfc_offset
1561 file_length (stream * s)
1562 {
1563   off_t curr, end;
1564   if (!is_seekable (s))
1565     return -1;
1566   curr = stell (s);
1567   if (curr == -1)
1568     return curr;
1569   end = sseek (s, 0, SEEK_END);
1570   sseek (s, curr, SEEK_SET);
1571   return end;
1572 }
1573
1574
1575 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1576  * it is not */
1577
1578 int
1579 is_seekable (stream *s)
1580 {
1581   /* By convention, if file_length == -1, the file is not
1582      seekable.  */
1583   return ((unix_stream *) s)->file_length!=-1;
1584 }
1585
1586
1587 /* is_special()-- Return nonzero if the stream is not a regular file.  */
1588
1589 int
1590 is_special (stream *s)
1591 {
1592   return ((unix_stream *) s)->special_file;
1593 }
1594
1595
1596 int
1597 stream_isatty (stream *s)
1598 {
1599   return isatty (((unix_stream *) s)->fd);
1600 }
1601
1602 char *
1603 stream_ttyname (stream *s __attribute__ ((unused)))
1604 {
1605 #ifdef HAVE_TTYNAME
1606   return ttyname (((unix_stream *) s)->fd);
1607 #else
1608   return NULL;
1609 #endif
1610 }
1611
1612
1613 /* How files are stored:  This is an operating-system specific issue,
1614    and therefore belongs here.  There are three cases to consider.
1615
1616    Direct Access:
1617       Records are written as block of bytes corresponding to the record
1618       length of the file.  This goes for both formatted and unformatted
1619       records.  Positioning is done explicitly for each data transfer,
1620       so positioning is not much of an issue.
1621
1622    Sequential Formatted:
1623       Records are separated by newline characters.  The newline character
1624       is prohibited from appearing in a string.  If it does, this will be
1625       messed up on the next read.  End of file is also the end of a record.
1626
1627    Sequential Unformatted:
1628       In this case, we are merely copying bytes to and from main storage,
1629       yet we need to keep track of varying record lengths.  We adopt
1630       the solution used by f2c.  Each record contains a pair of length
1631       markers:
1632
1633         Length of record n in bytes
1634         Data of record n
1635         Length of record n in bytes
1636
1637         Length of record n+1 in bytes
1638         Data of record n+1
1639         Length of record n+1 in bytes
1640
1641      The length is stored at the end of a record to allow backspacing to the
1642      previous record.  Between data transfer statements, the file pointer
1643      is left pointing to the first length of the current record.
1644
1645      ENDFILE records are never explicitly stored.
1646
1647 */