libgfortran/io/unix.c

   1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with Libgfortran; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Unix stream I/O module */
  22
  23 #include "config.h"
  24 #include <stdlib.h>
  25 #include <limits.h>
  26
  27 #include <unistd.h>
  28 #include <sys/stat.h>
  29 #include <fcntl.h>
  30
  31 #include <sys/mman.h>
  32 #include <string.h>
  33 #include <errno.h>
  34
  35 #include "libgfortran.h"
  36 #include "io.h"
  37
  38 #ifndef PATH_MAX
  39 #define PATH_MAX 1024
  40 #endif
  41
  42 #ifndef MAP_FAILED
  43 #define MAP_FAILED ((void *) -1)
  44 #endif
  45
  46 /* This implementation of stream I/O is based on the paper:
  47  *
  48  *  "Exploiting the advantages of mapped files for stream I/O",
  49  *  O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
  50  *  USENIX conference", p. 27-42.
  51  *
  52  * It differs in a number of ways from the version described in the
  53  * paper.  First of all, threads are not an issue during I/O and we
  54  * also don't have to worry about having multiple regions, since
  55  * fortran's I/O model only allows you to be one place at a time.
  56  *
  57  * On the other hand, we have to be able to writing at the end of a
  58  * stream, read from the start of a stream or read and write blocks of
  59  * bytes from an arbitrary position.  After opening a file, a pointer
  60  * to a stream structure is returned, which is used to handle file
  61  * accesses until the file is closed.
  62  *
  63  * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
  64  * pointer to a block of memory that mirror the file at position
  65  * 'where' that is 'len' bytes long.  The len integer is updated to
  66  * reflect how many bytes were actually read.  The only reason for a
  67  * short read is end of file.  The file pointer is updated.  The
  68  * pointer is valid until the next call to salloc_*.
  69  *
  70  * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
  71  * a pointer to a block of memory that is updated to reflect the state
  72  * of the file.  The length of the buffer is always equal to that
  73  * requested.  The buffer must be completely set by the caller.  When
  74  * data has been written, the sfree() function must be called to
  75  * indicate that the caller is done writing data to the buffer.  This
  76  * may or may not cause a physical write.
  77  *
  78  * Short forms of these are salloc_r() and salloc_w() which drop the
  79  * 'where' parameter and use the current file pointer. */
  80
  81
  82 #define BUFFER_SIZE 8192
  83
  84 typedef struct
  85 {
  86   stream st;
  87
  88   int fd;
  89   offset_t buffer_offset;       /* File offset of the start of the buffer */
  90   offset_t physical_offset;     /* Current physical file offset */
  91   offset_t logical_offset;      /* Current logical file offset */
  92   offset_t dirty_offset;        /* Start of modified bytes in buffer */
  93   offset_t file_length;         /* Length of the file, -1 if not seekable. */
  94
  95   char *buffer;
  96   int len;                      /* Physical length of the current buffer */
  97   int active;                   /* Length of valid bytes in the buffer */
  98
  99   int prot;
 100   int ndirty;                   /* Dirty bytes starting at dirty_offset */
 101
 102   unsigned unbuffered:1, mmaped:1;
 103
 104   char small_buffer[BUFFER_SIZE];
 105
 106 }
 107 unix_stream;
 108
 109 /*move_pos_offset()--  Move the record pointer right or left
 110  *relative to current position */
 111
 112 int
 113 move_pos_offset (stream* st, int pos_off)
 114 {
 115   unix_stream * str = (unix_stream*)st;
 116   if (pos_off < 0)
 117     {
 118       str->active  += pos_off;
 119       if (str->active < 0)
 120          str->active = 0;
 121
 122       str->logical_offset  += pos_off;
 123
 124       if (str->dirty_offset+str->ndirty > str->logical_offset)
 125         {
 126           if (str->ndirty +  pos_off > 0)
 127             str->ndirty += pos_off ;
 128           else
 129             {
 130               str->dirty_offset +=  pos_off + pos_off;
 131               str->ndirty = 0 ;
 132             }
 133         }
 134
 135     return pos_off ;
 136   }
 137   return 0 ;
 138 }
 139
 140
 141 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
 142  * standard descriptors, returning a non-standard descriptor.  If the
 143  * user specifies that system errors should go to standard output,
 144  * then closes standard output, we don't want the system errors to a
 145  * file that has been given file descriptor 1 or 0.  We want to send
 146  * the error to the invalid descriptor. */
 147
 148 static int
 149 fix_fd (int fd)
 150 {
 151   int input, output, error;
 152
 153   input = output = error = 0;
 154
 155 /* Unix allocates the lowest descriptors first, so a loop is not
 156  * required, but this order is. */
 157
 158   if (fd == STDIN_FILENO)
 159     {
 160       fd = dup (fd);
 161       input = 1;
 162     }
 163   if (fd == STDOUT_FILENO)
 164     {
 165       fd = dup (fd);
 166       output = 1;
 167     }
 168   if (fd == STDERR_FILENO)
 169     {
 170       fd = dup (fd);
 171       error = 1;
 172     }
 173
 174   if (input)
 175     close (STDIN_FILENO);
 176   if (output)
 177     close (STDOUT_FILENO);
 178   if (error)
 179     close (STDERR_FILENO);
 180
 181   return fd;
 182 }
 183
 184
 185 /* write()-- Write a buffer to a descriptor, allowing for short writes */
 186
 187 static int
 188 writen (int fd, char *buffer, int len)
 189 {
 190   int n, n0;
 191
 192   n0 = len;
 193
 194   while (len > 0)
 195     {
 196       n = write (fd, buffer, len);
 197       if (n < 0)
 198         return n;
 199
 200       buffer += n;
 201       len -= n;
 202     }
 203
 204   return n0;
 205 }
 206
 207
 208 #if 0
 209 /* readn()-- Read bytes into a buffer, allowing for short reads.  If
 210  * fewer than len bytes are returned, it is because we've hit the end
 211  * of file. */
 212
 213 static int
 214 readn (int fd, char *buffer, int len)
 215 {
 216   int nread, n;
 217
 218   nread = 0;
 219
 220   while (len > 0)
 221     {
 222       n = read (fd, buffer, len);
 223       if (n < 0)
 224         return n;
 225
 226       if (n == 0)
 227         return nread;
 228
 229       buffer += n;
 230       nread += n;
 231       len -= n;
 232     }
 233
 234   return nread;
 235 }
 236 #endif
 237
 238
 239 /* get_oserror()-- Get the most recent operating system error.  For
 240  * unix, this is errno. */
 241
 242 const char *
 243 get_oserror (void)
 244 {
 245
 246   return strerror (errno);
 247 }
 248
 249
 250 /* sys_exit()-- Terminate the program with an exit code */
 251
 252 void
 253 sys_exit (int code)
 254 {
 255
 256   exit (code);
 257 }
 258
 259
 260
 261 /*********************************************************************
 262     File descriptor stream functions
 263 *********************************************************************/
 264
 265 /* fd_flush()-- Write bytes that need to be written */
 266
 267 static try
 268 fd_flush (unix_stream * s)
 269 {
 270
 271   if (s->ndirty == 0)
 272     return SUCCESS;;
 273
 274   if (s->physical_offset != s->dirty_offset &&
 275       lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
 276     return FAILURE;
 277
 278   if (writen (s->fd, s->buffer + (s->dirty_offset - s->buffer_offset),
 279               s->ndirty) < 0)
 280     return FAILURE;
 281
 282   s->physical_offset = s->dirty_offset + s->ndirty;
 283   if (s->physical_offset > s->file_length)
 284     s->file_length = s->physical_offset;
 285   s->ndirty = 0;
 286
 287   return SUCCESS;
 288 }
 289
 290
 291 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
 292  * satisfied.  This subroutine gets the buffer ready for whatever is
 293  * to come next. */
 294
 295 static void
 296 fd_alloc (unix_stream * s, offset_t where, int *len)
 297 {
 298   char *new_buffer;
 299   int n, read_len;
 300
 301   if (*len <= BUFFER_SIZE)
 302     {
 303       new_buffer = s->small_buffer;
 304       read_len = BUFFER_SIZE;
 305     }
 306   else
 307     {
 308       new_buffer = get_mem (*len);
 309       read_len = *len;
 310     }
 311
 312   /* Salvage bytes currently within the buffer.  This is important for
 313    * devices that cannot seek. */
 314
 315   if (s->buffer != NULL && s->buffer_offset <= where &&
 316       where <= s->buffer_offset + s->active)
 317     {
 318
 319       n = s->active - (where - s->buffer_offset);
 320       memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
 321
 322       s->active = n;
 323     }
 324   else
 325     {                           /* new buffer starts off empty */
 326       s->active = 0;
 327     }
 328
 329   s->buffer_offset = where;
 330
 331   /* free the old buffer if necessary */
 332
 333   if (s->buffer != NULL && s->buffer != s->small_buffer)
 334     free_mem (s->buffer);
 335
 336   s->buffer = new_buffer;
 337   s->len = read_len;
 338   s->mmaped = 0;
 339 }
 340
 341
 342 /* fd_alloc_r_at()-- Allocate a stream buffer for reading.  Either
 343  * we've already buffered the data or we need to load it.  Returns
 344  * NULL on I/O error. */
 345
 346 static char *
 347 fd_alloc_r_at (unix_stream * s, int *len, offset_t where)
 348 {
 349   offset_t m;
 350   int n;
 351
 352   if (where == -1)
 353     where = s->logical_offset;
 354
 355   if (s->buffer != NULL && s->buffer_offset <= where &&
 356       where + *len <= s->buffer_offset + s->active)
 357     {
 358
 359       /* Return a position within the current buffer */
 360
 361       s->logical_offset = where + *len;
 362       return s->buffer + where - s->buffer_offset;
 363     }
 364
 365   fd_alloc (s, where, len);
 366
 367   m = where + s->active;
 368
 369   if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
 370     return NULL;
 371
 372   n = read (s->fd, s->buffer + s->active, s->len - s->active);
 373   if (n < 0)
 374     return NULL;
 375
 376   s->physical_offset = where + n;
 377
 378   s->active += n;
 379   if (s->active < *len)
 380     *len = s->active;           /* Bytes actually available */
 381
 382   s->logical_offset = where + *len;
 383
 384   return s->buffer;
 385 }
 386
 387
 388 /* fd_alloc_w_at()-- Allocate a stream buffer for writing.  Either
 389  * we've already buffered the data or we need to load it. */
 390
 391 static char *
 392 fd_alloc_w_at (unix_stream * s, int *len, offset_t where)
 393 {
 394   offset_t n;
 395
 396   if (where == -1)
 397     where = s->logical_offset;
 398
 399   if (s->buffer == NULL || s->buffer_offset > where ||
 400       where + *len > s->buffer_offset + s->len)
 401     {
 402
 403       if (fd_flush (s) == FAILURE)
 404         return NULL;
 405       fd_alloc (s, where, len);
 406     }
 407
 408   /* Return a position within the current buffer */
 409
 410   if (s->ndirty == 0)
 411     {                           /* First write into a clean buffer */
 412       s->dirty_offset = where;
 413       s->ndirty = *len;
 414     }
 415   else
 416     {
 417       if (s->dirty_offset + s->ndirty == where)
 418         s->ndirty += *len;
 419       else
 420         fd_flush (s);           /* Can't combine two dirty blocks */
 421     }
 422
 423   s->logical_offset = where + *len;
 424
 425   n = s->logical_offset - s->buffer_offset;
 426   if (n > s->active)
 427     s->active = n;
 428
 429   return s->buffer + where - s->buffer_offset;
 430 }
 431
 432
 433 static try
 434 fd_sfree (unix_stream * s)
 435 {
 436
 437   if (s->ndirty != 0 &&
 438       (s->buffer != s->small_buffer || options.all_unbuffered ||
 439        s->unbuffered))
 440     return fd_flush (s);
 441
 442   return SUCCESS;
 443 }
 444
 445
 446 static int
 447 fd_seek (unix_stream * s, offset_t offset)
 448 {
 449
 450   s->physical_offset = s->logical_offset = offset;
 451
 452   return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
 453 }
 454
 455
 456 /* truncate_file()-- Given a unit, truncate the file at the current
 457  * position.  Sets the physical location to the new end of the file.
 458  * Returns nonzero on error. */
 459
 460 static try
 461 fd_truncate (unix_stream * s)
 462 {
 463
 464   if (ftruncate (s->fd, s->logical_offset))
 465     return FAILURE;
 466
 467   s->physical_offset = s->file_length = s->logical_offset;
 468
 469   if (lseek (s->fd, s->file_length, SEEK_SET) == -1)
 470     return FAILURE;
 471
 472   return SUCCESS;
 473 }
 474
 475
 476 static try
 477 fd_close (unix_stream * s)
 478 {
 479
 480   if (fd_flush (s) == FAILURE)
 481     return FAILURE;
 482
 483   if (s->buffer != NULL && s->buffer != s->small_buffer)
 484     free_mem (s->buffer);
 485
 486   if (close (s->fd) < 0)
 487     return FAILURE;
 488
 489   free_mem (s);
 490
 491   return SUCCESS;
 492 }
 493
 494
 495 static void
 496 fd_open (unix_stream * s)
 497 {
 498
 499   if (isatty (s->fd))
 500     s->unbuffered = 1;
 501
 502   s->st.alloc_r_at = (void *) fd_alloc_r_at;
 503   s->st.alloc_w_at = (void *) fd_alloc_w_at;
 504   s->st.sfree = (void *) fd_sfree;
 505   s->st.close = (void *) fd_close;
 506   s->st.seek = (void *) fd_seek;
 507   s->st.truncate = (void *) fd_truncate;
 508
 509   s->buffer = NULL;
 510 }
 511
 512
 513 /*********************************************************************
 514     mmap stream functions
 515
 516  Because mmap() is not capable of extending a file, we have to keep
 517  track of how long the file is.  We also have to be able to detect end
 518  of file conditions.  If there are multiple writers to the file (which
 519  can only happen outside the current program), things will get
 520  confused.  Then again, things will get confused anyway.
 521
 522 *********************************************************************/
 523
 524 #if HAVE_MMAP
 525
 526 static int page_size, page_mask;
 527
 528 /* mmap_flush()-- Deletes a memory mapping if something is mapped. */
 529
 530 static try
 531 mmap_flush (unix_stream * s)
 532 {
 533
 534   if (!s->mmaped)
 535     return fd_flush (s);
 536
 537   if (s->buffer == NULL)
 538     return SUCCESS;
 539
 540   if (munmap (s->buffer, s->active))
 541     return FAILURE;
 542
 543   s->buffer = NULL;
 544   s->active = 0;
 545
 546   return SUCCESS;
 547 }
 548
 549
 550 /* mmap_alloc()-- mmap() a section of the file.  The whole section is
 551  * guaranteed to be mappable. */
 552
 553 static try
 554 mmap_alloc (unix_stream * s, offset_t where, int *len)
 555 {
 556   offset_t offset;
 557   int length;
 558   char *p;
 559
 560   if (mmap_flush (s) == FAILURE)
 561     return FAILURE;
 562
 563   offset = where & page_mask;   /* Round down to the next page */
 564
 565   length = ((where - offset) & page_mask) + 2 * page_size;
 566
 567   p = mmap (NULL, length, s->prot, MAP_SHARED, s->fd, offset);
 568   if (p == (char *) MAP_FAILED)
 569     return FAILURE;
 570
 571   s->mmaped = 1;
 572   s->buffer = p;
 573   s->buffer_offset = offset;
 574   s->active = length;
 575
 576   return SUCCESS;
 577 }
 578
 579
 580 static char *
 581 mmap_alloc_r_at (unix_stream * s, int *len, offset_t where)
 582 {
 583   offset_t m;
 584
 585   if (where == -1)
 586     where = s->logical_offset;
 587
 588   m = where + *len;
 589
 590   if ((s->buffer == NULL || s->buffer_offset > where ||
 591        m > s->buffer_offset + s->active) &&
 592       mmap_alloc (s, where, len) == FAILURE)
 593     return NULL;
 594
 595   if (m > s->file_length)
 596     {
 597       *len = s->file_length - s->logical_offset;
 598       s->logical_offset = s->file_length;
 599     }
 600   else
 601     s->logical_offset = m;
 602
 603   return s->buffer + (where - s->buffer_offset);
 604 }
 605
 606
 607 static char *
 608 mmap_alloc_w_at (unix_stream * s, int *len, offset_t where)
 609 {
 610   if (where == -1)
 611     where = s->logical_offset;
 612
 613   /* If we're extending the file, we have to use file descriptor
 614    * methods. */
 615
 616   if (where + *len > s->file_length)
 617     {
 618       if (s->mmaped)
 619         mmap_flush (s);
 620       return fd_alloc_w_at (s, len, where);
 621     }
 622
 623   if ((s->buffer == NULL || s->buffer_offset > where ||
 624        where + *len > s->buffer_offset + s->active) &&
 625       mmap_alloc (s, where, len) == FAILURE)
 626     return NULL;
 627
 628   s->logical_offset = where + *len;
 629
 630   return s->buffer + where - s->buffer_offset;
 631 }
 632
 633
 634 static int
 635 mmap_seek (unix_stream * s, offset_t offset)
 636 {
 637
 638   s->logical_offset = offset;
 639   return SUCCESS;
 640 }
 641
 642
 643 static try
 644 mmap_close (unix_stream * s)
 645 {
 646   try t;
 647
 648   t = mmap_flush (s);
 649
 650   if (close (s->fd) < 0)
 651     t = FAILURE;
 652   free_mem (s);
 653
 654   return t;
 655 }
 656
 657
 658 static try
 659 mmap_sfree (unix_stream * s)
 660 {
 661
 662   return SUCCESS;
 663 }
 664
 665
 666 /* mmap_open()-- mmap_specific open.  If the particular file cannot be
 667  * mmap()-ed, we fall back to the file descriptor functions. */
 668
 669 static try
 670 mmap_open (unix_stream * s)
 671 {
 672   char *p;
 673   int i;
 674
 675   page_size = getpagesize ();
 676   page_mask = ~0;
 677
 678   p = mmap (0, page_size, s->prot, MAP_SHARED, s->fd, 0);
 679   if (p == (char *) MAP_FAILED)
 680     {
 681       fd_open (s);
 682       return SUCCESS;
 683     }
 684
 685   munmap (p, page_size);
 686
 687   i = page_size >> 1;
 688   while (i != 0)
 689     {
 690       page_mask <<= 1;
 691       i >>= 1;
 692     }
 693
 694   s->st.alloc_r_at = (void *) mmap_alloc_r_at;
 695   s->st.alloc_w_at = (void *) mmap_alloc_w_at;
 696   s->st.sfree = (void *) mmap_sfree;
 697   s->st.close = (void *) mmap_close;
 698   s->st.seek = (void *) mmap_seek;
 699   s->st.truncate = (void *) fd_truncate;
 700
 701   if (lseek (s->fd, s->file_length, SEEK_SET) < 0)
 702     return FAILURE;
 703
 704   return SUCCESS;
 705 }
 706
 707 #endif
 708
 709
 710 /*********************************************************************
 711   memory stream functions - These are used for internal files
 712
 713   The idea here is that a single stream structure is created and all
 714   requests must be satisfied from it.  The location and size of the
 715   buffer is the character variable supplied to the READ or WRITE
 716   statement.
 717
 718 *********************************************************************/
 719
 720
 721 static char *
 722 mem_alloc_r_at (unix_stream * s, int *len, offset_t where)
 723 {
 724   offset_t n;
 725
 726   if (where == -1)
 727     where = s->logical_offset;
 728
 729   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 730     return NULL;
 731
 732   if (is_internal_unit() && where + *len > s->file_length)
 733     return NULL;
 734
 735   s->logical_offset = where + *len;
 736
 737   n = (where - s->buffer_offset) - s->active;
 738   if (*len > n)
 739     *len = n;
 740
 741   return s->buffer + (where - s->buffer_offset);
 742 }
 743
 744
 745 static char *
 746 mem_alloc_w_at (unix_stream * s, int *len, offset_t where)
 747 {
 748   offset_t m;
 749
 750   if (where == -1)
 751     where = s->logical_offset;
 752
 753   m = where + *len;
 754
 755   if (where < s->buffer_offset || m > s->buffer_offset + s->active)
 756     return NULL;
 757
 758   s->logical_offset = m;
 759
 760   return s->buffer + (where - s->buffer_offset);
 761 }
 762
 763
 764 static int
 765 mem_seek (unix_stream * s, offset_t offset)
 766 {
 767
 768   if (offset > s->file_length)
 769     {
 770       errno = ESPIPE;
 771       return FAILURE;
 772     }
 773
 774   s->logical_offset = offset;
 775   return SUCCESS;
 776 }
 777
 778
 779 static int
 780 mem_truncate (unix_stream * s)
 781 {
 782
 783   return SUCCESS;
 784 }
 785
 786
 787 static try
 788 mem_close (unix_stream * s)
 789 {
 790
 791   return SUCCESS;
 792 }
 793
 794
 795 static try
 796 mem_sfree (unix_stream * s)
 797 {
 798
 799   return SUCCESS;
 800 }
 801
 802
 803
 804 /*********************************************************************
 805   Public functions -- A reimplementation of this module needs to
 806   define functional equivalents of the following.
 807 *********************************************************************/
 808
 809 /* empty_internal_buffer()-- Zero the buffer of Internal file */
 810
 811 void
 812 empty_internal_buffer(stream *strm)
 813 {
 814    unix_stream * s = (unix_stream *) strm;
 815    memset(s->buffer, ' ', s->file_length);
 816 }
 817
 818 /* open_internal()-- Returns a stream structure from an internal file */
 819
 820 stream *
 821 open_internal (char *base, int length)
 822 {
 823   unix_stream *s;
 824
 825   s = get_mem (sizeof (unix_stream));
 826
 827   s->buffer = base;
 828   s->buffer_offset = 0;
 829
 830   s->logical_offset = 0;
 831   s->active = s->file_length = length;
 832
 833   s->st.alloc_r_at = (void *) mem_alloc_r_at;
 834   s->st.alloc_w_at = (void *) mem_alloc_w_at;
 835   s->st.sfree = (void *) mem_sfree;
 836   s->st.close = (void *) mem_close;
 837   s->st.seek = (void *) mem_seek;
 838   s->st.truncate = (void *) mem_truncate;
 839
 840   return (stream *) s;
 841 }
 842
 843
 844 /* fd_to_stream()-- Given an open file descriptor, build a stream
 845  * around it. */
 846
 847 static stream *
 848 fd_to_stream (int fd, int prot)
 849 {
 850   struct stat statbuf;
 851   unix_stream *s;
 852
 853   s = get_mem (sizeof (unix_stream));
 854
 855   s->fd = fd;
 856   s->buffer_offset = 0;
 857   s->physical_offset = 0;
 858   s->logical_offset = 0;
 859   s->prot = prot;
 860
 861   /* Get the current length of the file. */
 862
 863   fstat (fd, &statbuf);
 864   s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
 865
 866 #if HAVE_MMAP
 867   mmap_open (s);
 868 #else
 869   fd_open (s);
 870 #endif
 871
 872   return (stream *) s;
 873 }
 874
 875
 876 /* unpack_filename()-- Given a fortran string and a pointer to a
 877  * buffer that is PATH_MAX characters, convert the fortran string to a
 878  * C string in the buffer.  Returns nonzero if this is not possible.  */
 879
 880 static int
 881 unpack_filename (char *cstring, const char *fstring, int len)
 882 {
 883
 884   len = fstrlen (fstring, len);
 885   if (len >= PATH_MAX)
 886     return 1;
 887
 888   memmove (cstring, fstring, len);
 889   cstring[len] = '\0';
 890
 891   return 0;
 892 }
 893
 894
 895 /* tempfile()-- Generate a temporary filename for a scratch file and
 896  * open it.  mkstemp() opens the file for reading and writing, but the
 897  * library mode prevents anything that is not allowed.  The descriptor
 898  * is returns, which is less than zero on error.  The template is
 899  * pointed to by ioparm.file, which is copied into the unit structure
 900  * and freed later. */
 901
 902 static int
 903 tempfile (void)
 904 {
 905   const char *tempdir;
 906   char *template;
 907   int fd;
 908
 909   tempdir = getenv ("GFORTRAN_TMPDIR");
 910   if (tempdir == NULL)
 911     tempdir = getenv ("TMP");
 912   if (tempdir == NULL)
 913     tempdir = DEFAULT_TEMPDIR;
 914
 915   template = get_mem (strlen (tempdir) + 20);
 916
 917   st_sprintf (template, "%s/gfortantmpXXXXXX", tempdir);
 918
 919   fd = mkstemp (template);
 920
 921   if (fd < 0)
 922     free_mem (template);
 923   else
 924     {
 925       ioparm.file = template;
 926       ioparm.file_len = strlen (template);      /* Don't include trailing nul */
 927     }
 928
 929   return fd;
 930 }
 931
 932
 933 /* regular_file()-- Open a regular file.  Returns the descriptor, which is less than zero on error. */
 934
 935 static int
 936 regular_file (unit_action action, unit_status status)
 937 {
 938   char path[PATH_MAX + 1];
 939   struct stat statbuf;
 940   int mode;
 941
 942   if (unpack_filename (path, ioparm.file, ioparm.file_len))
 943     {
 944       errno = ENOENT;           /* Fake an OS error */
 945       return -1;
 946     }
 947
 948   mode = 0;
 949
 950   switch (action)
 951     {
 952     case ACTION_READ:
 953       mode = O_RDONLY;
 954       break;
 955
 956     case ACTION_WRITE:
 957       mode = O_WRONLY;
 958       break;
 959
 960     case ACTION_READWRITE:
 961       mode = O_RDWR;
 962       break;
 963
 964     default:
 965       internal_error ("regular_file(): Bad action");
 966     }
 967
 968   switch (status)
 969     {
 970     case STATUS_NEW:
 971       mode |= O_CREAT | O_EXCL;
 972       break;
 973
 974     case STATUS_OLD:            /* file must exist, so check for its existence */
 975       if (stat (path, &statbuf) < 0)
 976         return -1;
 977       break;
 978
 979     case STATUS_UNKNOWN:
 980     case STATUS_SCRATCH:
 981       mode |= O_CREAT;
 982       break;
 983
 984     case STATUS_REPLACE:
 985       mode |= O_TRUNC;
 986       break;
 987
 988     default:
 989       internal_error ("regular_file(): Bad status");
 990     }
 991
 992   // mode |= O_LARGEFILE;
 993
 994   return open (path, mode,
 995                S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH);
 996 }
 997
 998
 999 /* open_external()-- Open an external file, unix specific version.
1000  * Returns NULL on operating system error. */
1001
1002 stream *
1003 open_external (unit_action action, unit_status status)
1004 {
1005   int fd, prot;
1006
1007   fd =
1008     (status == STATUS_SCRATCH) ? tempfile () : regular_file (action, status);
1009
1010   if (fd < 0)
1011     return NULL;
1012   fd = fix_fd (fd);
1013
1014   switch (action)
1015     {
1016     case ACTION_READ:
1017       prot = PROT_READ;
1018       break;
1019
1020     case ACTION_WRITE:
1021       prot = PROT_WRITE;
1022       break;
1023
1024     case ACTION_READWRITE:
1025       prot = PROT_READ | PROT_WRITE;
1026       break;
1027
1028     default:
1029       internal_error ("open_external(): Bad action");
1030     }
1031
1032   /* If this is a scratch file, we can unlink it now and the file will
1033    * go away when it is closed. */
1034
1035   if (status == STATUS_SCRATCH)
1036     unlink (ioparm.file);
1037
1038   return fd_to_stream (fd, prot);
1039 }
1040
1041
1042 /* input_stream()-- Return a stream pointer to the default input stream.
1043  * Called on initialization. */
1044
1045 stream *
1046 input_stream (void)
1047 {
1048
1049   return fd_to_stream (STDIN_FILENO, PROT_READ);
1050 }
1051
1052
1053 /* output_stream()-- Return a stream pointer to the default input stream.
1054  * Called on initialization. */
1055
1056 stream *
1057 output_stream (void)
1058 {
1059
1060   return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1061 }
1062
1063
1064 /* init_error_stream()-- Return a pointer to the error stream.  This
1065  * subroutine is called when the stream is needed, rather than at
1066  * initialization.  We want to work even if memory has been seriously
1067  * corrupted. */
1068
1069 stream *
1070 init_error_stream (void)
1071 {
1072   static unix_stream error;
1073
1074   memset (&error, '\0', sizeof (error));
1075
1076   error.fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1077
1078   error.st.alloc_w_at = (void *) fd_alloc_w_at;
1079   error.st.sfree = (void *) fd_sfree;
1080
1081   error.unbuffered = 1;
1082   error.buffer = error.small_buffer;
1083
1084   return (stream *) & error;
1085 }
1086
1087
1088 /* compare_file_filename()-- Given an open stream and a fortran string
1089  * that is a filename, figure out if the file is the same as the
1090  * filename. */
1091
1092 int
1093 compare_file_filename (stream * s, const char *name, int len)
1094 {
1095   char path[PATH_MAX + 1];
1096   struct stat st1, st2;
1097
1098   if (unpack_filename (path, name, len))
1099     return 0;                   /* Can't be the same */
1100
1101   /* If the filename doesn't exist, then there is no match with the
1102    * existing file. */
1103
1104   if (stat (path, &st1) < 0)
1105     return 0;
1106
1107   fstat (((unix_stream *) s)->fd, &st2);
1108
1109   return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1110 }
1111
1112
1113 /* find_file0()-- Recursive work function for find_file() */
1114
1115 static unit_t *
1116 find_file0 (unit_t * u, struct stat *st1)
1117 {
1118   struct stat st2;
1119   unit_t *v;
1120
1121   if (u == NULL)
1122     return NULL;
1123
1124   if (fstat (((unix_stream *) u->s)->fd, &st2) >= 0 &&
1125       st1->st_dev == st2.st_dev && st1->st_ino == st2.st_ino)
1126     return u;
1127
1128   v = find_file0 (u->left, st1);
1129   if (v != NULL)
1130     return v;
1131
1132   v = find_file0 (u->right, st1);
1133   if (v != NULL)
1134     return v;
1135
1136   return NULL;
1137 }
1138
1139
1140 /* find_file()-- Take the current filename and see if there is a unit
1141  * that has the file already open.  Returns a pointer to the unit if so. */
1142
1143 unit_t *
1144 find_file (void)
1145 {
1146   char path[PATH_MAX + 1];
1147   struct stat statbuf;
1148
1149   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1150     return NULL;
1151
1152   if (stat (path, &statbuf) < 0)
1153     return NULL;
1154
1155   return find_file0 (g.unit_root, &statbuf);
1156 }
1157
1158
1159 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1160  * of the file. */
1161
1162 int
1163 stream_at_bof (stream * s)
1164 {
1165   unix_stream *us;
1166
1167   us = (unix_stream *) s;
1168
1169   if (!us->mmaped)
1170     return 0;                   /* File is not seekable */
1171
1172   return us->logical_offset == 0;
1173 }
1174
1175
1176 /* stream_at_eof()-- Returns nonzero if the stream is at the beginning
1177  * of the file. */
1178
1179 int
1180 stream_at_eof (stream * s)
1181 {
1182   unix_stream *us;
1183
1184   us = (unix_stream *) s;
1185
1186   if (!us->mmaped)
1187     return 0;                   /* File is not seekable */
1188
1189   return us->logical_offset == us->dirty_offset;
1190 }
1191
1192
1193 /* delete_file()-- Given a unit structure, delete the file associated
1194  * with the unit.  Returns nonzero if something went wrong. */
1195
1196 int
1197 delete_file (unit_t * u)
1198 {
1199   char path[PATH_MAX + 1];
1200
1201   if (unpack_filename (path, u->file, u->file_len))
1202     {                           /* Shouldn't be possible */
1203       errno = ENOENT;
1204       return 1;
1205     }
1206
1207   return unlink (path);
1208 }
1209
1210
1211 /* file_exists()-- Returns nonzero if the current filename exists on
1212  * the system */
1213
1214 int
1215 file_exists (void)
1216 {
1217   char path[PATH_MAX + 1];
1218   struct stat statbuf;
1219
1220   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1221     return 0;
1222
1223   if (stat (path, &statbuf) < 0)
1224     return 0;
1225
1226   return 1;
1227 }
1228
1229
1230
1231 static const char *yes = "YES", *no = "NO", *unknown = "UNKNOWN";
1232
1233 /* inquire_sequential()-- Given a fortran string, determine if the
1234  * file is suitable for sequential access.  Returns a C-style
1235  * string. */
1236
1237 const char *
1238 inquire_sequential (const char *string, int len)
1239 {
1240   char path[PATH_MAX + 1];
1241   struct stat statbuf;
1242
1243   if (string == NULL ||
1244       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1245     return unknown;
1246
1247   if (S_ISREG (statbuf.st_mode) ||
1248       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1249     return yes;
1250
1251   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1252     return no;
1253
1254   return unknown;
1255 }
1256
1257
1258 /* inquire_direct()-- Given a fortran string, determine if the file is
1259  * suitable for direct access.  Returns a C-style string. */
1260
1261 const char *
1262 inquire_direct (const char *string, int len)
1263 {
1264   char path[PATH_MAX + 1];
1265   struct stat statbuf;
1266
1267   if (string == NULL ||
1268       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1269     return unknown;
1270
1271   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1272     return yes;
1273
1274   if (S_ISDIR (statbuf.st_mode) ||
1275       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1276     return no;
1277
1278   return unknown;
1279 }
1280
1281
1282 /* inquire_formatted()-- Given a fortran string, determine if the file
1283  * is suitable for formatted form.  Returns a C-style string. */
1284
1285 const char *
1286 inquire_formatted (const char *string, int len)
1287 {
1288   char path[PATH_MAX + 1];
1289   struct stat statbuf;
1290
1291   if (string == NULL ||
1292       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1293     return unknown;
1294
1295   if (S_ISREG (statbuf.st_mode) ||
1296       S_ISBLK (statbuf.st_mode) ||
1297       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1298     return yes;
1299
1300   if (S_ISDIR (statbuf.st_mode))
1301     return no;
1302
1303   return unknown;
1304 }
1305
1306
1307 /* inquire_unformatted()-- Given a fortran string, determine if the file
1308  * is suitable for unformatted form.  Returns a C-style string. */
1309
1310 const char *
1311 inquire_unformatted (const char *string, int len)
1312 {
1313
1314   return inquire_formatted (string, len);
1315 }
1316
1317
1318 /* inquire_access()-- Given a fortran string, determine if the file is
1319  * suitable for access. */
1320
1321 static const char *
1322 inquire_access (const char *string, int len, int mode)
1323 {
1324   char path[PATH_MAX + 1];
1325
1326   if (string == NULL || unpack_filename (path, string, len) ||
1327       access (path, mode) < 0)
1328     return no;
1329
1330   return yes;
1331 }
1332
1333
1334 /* inquire_read()-- Given a fortran string, determine if the file is
1335  * suitable for READ access. */
1336
1337 const char *
1338 inquire_read (const char *string, int len)
1339 {
1340
1341   return inquire_access (string, len, R_OK);
1342 }
1343
1344
1345 /* inquire_write()-- Given a fortran string, determine if the file is
1346  * suitable for READ access. */
1347
1348 const char *
1349 inquire_write (const char *string, int len)
1350 {
1351
1352   return inquire_access (string, len, W_OK);
1353 }
1354
1355
1356 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1357  * suitable for read and write access. */
1358
1359 const char *
1360 inquire_readwrite (const char *string, int len)
1361 {
1362
1363   return inquire_access (string, len, R_OK | W_OK);
1364 }
1365
1366
1367 /* file_length()-- Return the file length in bytes, -1 if unknown */
1368
1369 offset_t
1370 file_length (stream * s)
1371 {
1372
1373   return ((unix_stream *) s)->file_length;
1374 }
1375
1376
1377 /* file_position()-- Return the current position of the file */
1378
1379 offset_t
1380 file_position (stream * s)
1381 {
1382
1383   return ((unix_stream *) s)->logical_offset;
1384 }
1385
1386
1387 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1388  * it is not */
1389
1390 int
1391 is_seekable (stream * s)
1392 {
1393
1394   return ((unix_stream *) s)->mmaped;
1395 }
1396
1397
1398 /* How files are stored:  This is an operating-system specific issue,
1399    and therefore belongs here.  There are three cases to consider.
1400
1401    Direct Access:
1402       Records are written as block of bytes corresponding to the record
1403       length of the file.  This goes for both formatted and unformatted
1404       records.  Positioning is done explicitly for each data transfer,
1405       so positioning is not much of an issue.
1406
1407    Sequential Formatted:
1408       Records are separated by newline characters.  The newline character
1409       is prohibited from appearing in a string.  If it does, this will be
1410       messed up on the next read.  End of file is also the end of a record.
1411
1412    Sequential Unformatted:
1413       In this case, we are merely copying bytes to and from main storage,
1414       yet we need to keep track of varying record lengths.  We adopt
1415       the solution used by f2c.  Each record contains a pair of length
1416       markers:
1417
1418         Length of record n in bytes
1419         Data of record n
1420         Length of record n in bytes
1421
1422         Length of record n+1 in bytes
1423         Data of record n+1
1424         Length of record n+1 in bytes
1425
1426      The length is stored at the end of a record to allow backspacing to the
1427      previous record.  Between data transfer statements, the file pointer
1428      is left pointing to the first length of the current record.
1429
1430      ENDFILE records are never explicitly stored.
1431
1432 */