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   gfc_offset buffer_offset;     /* File offset of the start of the buffer */
  90   gfc_offset physical_offset;   /* Current physical file offset */
  91   gfc_offset logical_offset;    /* Current logical file offset */
  92   gfc_offset dirty_offset;      /* Start of modified bytes in buffer */
  93   gfc_offset 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
 284   /* don't increment file_length if the file is non-seekable */
 285   if (s->file_length != -1 && s->physical_offset > s->file_length)
 286     s->file_length = s->physical_offset;
 287   s->ndirty = 0;
 288
 289   return SUCCESS;
 290 }
 291
 292
 293 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
 294  * satisfied.  This subroutine gets the buffer ready for whatever is
 295  * to come next. */
 296
 297 static void
 298 fd_alloc (unix_stream * s, gfc_offset where, int *len)
 299 {
 300   char *new_buffer;
 301   int n, read_len;
 302
 303   if (*len <= BUFFER_SIZE)
 304     {
 305       new_buffer = s->small_buffer;
 306       read_len = BUFFER_SIZE;
 307     }
 308   else
 309     {
 310       new_buffer = get_mem (*len);
 311       read_len = *len;
 312     }
 313
 314   /* Salvage bytes currently within the buffer.  This is important for
 315    * devices that cannot seek. */
 316
 317   if (s->buffer != NULL && s->buffer_offset <= where &&
 318       where <= s->buffer_offset + s->active)
 319     {
 320
 321       n = s->active - (where - s->buffer_offset);
 322       memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
 323
 324       s->active = n;
 325     }
 326   else
 327     {                           /* new buffer starts off empty */
 328       s->active = 0;
 329     }
 330
 331   s->buffer_offset = where;
 332
 333   /* free the old buffer if necessary */
 334
 335   if (s->buffer != NULL && s->buffer != s->small_buffer)
 336     free_mem (s->buffer);
 337
 338   s->buffer = new_buffer;
 339   s->len = read_len;
 340   s->mmaped = 0;
 341 }
 342
 343
 344 /* fd_alloc_r_at()-- Allocate a stream buffer for reading.  Either
 345  * we've already buffered the data or we need to load it.  Returns
 346  * NULL on I/O error. */
 347
 348 static char *
 349 fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
 350 {
 351   gfc_offset m;
 352   int n;
 353
 354   if (where == -1)
 355     where = s->logical_offset;
 356
 357   if (s->buffer != NULL && s->buffer_offset <= where &&
 358       where + *len <= s->buffer_offset + s->active)
 359     {
 360
 361       /* Return a position within the current buffer */
 362
 363       s->logical_offset = where + *len;
 364       return s->buffer + where - s->buffer_offset;
 365     }
 366
 367   fd_alloc (s, where, len);
 368
 369   m = where + s->active;
 370
 371   if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
 372     return NULL;
 373
 374   n = read (s->fd, s->buffer + s->active, s->len - s->active);
 375   if (n < 0)
 376     return NULL;
 377
 378   s->physical_offset = where + n;
 379
 380   s->active += n;
 381   if (s->active < *len)
 382     *len = s->active;           /* Bytes actually available */
 383
 384   s->logical_offset = where + *len;
 385
 386   return s->buffer;
 387 }
 388
 389
 390 /* fd_alloc_w_at()-- Allocate a stream buffer for writing.  Either
 391  * we've already buffered the data or we need to load it. */
 392
 393 static char *
 394 fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
 395 {
 396   gfc_offset n;
 397
 398   if (where == -1)
 399     where = s->logical_offset;
 400
 401   if (s->buffer == NULL || s->buffer_offset > where ||
 402       where + *len > s->buffer_offset + s->len)
 403     {
 404
 405       if (fd_flush (s) == FAILURE)
 406         return NULL;
 407       fd_alloc (s, where, len);
 408     }
 409
 410   /* Return a position within the current buffer */
 411   if (s->ndirty == 0
 412       || where > s->dirty_offset + s->ndirty
 413       || s->dirty_offset > where + *len)
 414     {  /* Discontiguous blocks, start with a clean buffer.  */
 415         /* Flush the buffer.  */
 416        if (s->ndirty != 0)
 417          fd_flush (s);
 418        s->dirty_offset = where;
 419        s->ndirty = *len;
 420     }
 421   else
 422     {
 423       gfc_offset start;  /* Merge with the existing data.  */
 424       if (where < s->dirty_offset)
 425         start = where;
 426       else
 427         start = s->dirty_offset;
 428       if (where + *len > s->dirty_offset + s->ndirty)
 429         s->ndirty = where + *len - start;
 430       else
 431         s->ndirty = s->dirty_offset + s->ndirty - start;
 432         s->dirty_offset = start;
 433     }
 434
 435   s->logical_offset = where + *len;
 436
 437   n = s->logical_offset - s->buffer_offset;
 438   if (n > s->active)
 439     s->active = n;
 440
 441   return s->buffer + where - s->buffer_offset;
 442 }
 443
 444
 445 static try
 446 fd_sfree (unix_stream * s)
 447 {
 448
 449   if (s->ndirty != 0 &&
 450       (s->buffer != s->small_buffer || options.all_unbuffered ||
 451        s->unbuffered))
 452     return fd_flush (s);
 453
 454   return SUCCESS;
 455 }
 456
 457
 458 static int
 459 fd_seek (unix_stream * s, gfc_offset offset)
 460 {
 461
 462   s->physical_offset = s->logical_offset = offset;
 463
 464   return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
 465 }
 466
 467
 468 /* truncate_file()-- Given a unit, truncate the file at the current
 469  * position.  Sets the physical location to the new end of the file.
 470  * Returns nonzero on error. */
 471
 472 static try
 473 fd_truncate (unix_stream * s)
 474 {
 475
 476   if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
 477     return FAILURE;
 478
 479   /* non-seekable files, like terminals and fifo's fail the lseek.
 480      the fd is a regular file at this point */
 481
 482   if (ftruncate (s->fd, s->logical_offset))
 483    {
 484     return FAILURE;
 485    }
 486
 487   s->physical_offset = s->file_length = s->logical_offset;
 488
 489   return SUCCESS;
 490 }
 491
 492
 493 static try
 494 fd_close (unix_stream * s)
 495 {
 496
 497   if (fd_flush (s) == FAILURE)
 498     return FAILURE;
 499
 500   if (s->buffer != NULL && s->buffer != s->small_buffer)
 501     free_mem (s->buffer);
 502
 503   if (close (s->fd) < 0)
 504     return FAILURE;
 505
 506   free_mem (s);
 507
 508   return SUCCESS;
 509 }
 510
 511
 512 static void
 513 fd_open (unix_stream * s)
 514 {
 515
 516   if (isatty (s->fd))
 517     s->unbuffered = 1;
 518
 519   s->st.alloc_r_at = (void *) fd_alloc_r_at;
 520   s->st.alloc_w_at = (void *) fd_alloc_w_at;
 521   s->st.sfree = (void *) fd_sfree;
 522   s->st.close = (void *) fd_close;
 523   s->st.seek = (void *) fd_seek;
 524   s->st.truncate = (void *) fd_truncate;
 525
 526   s->buffer = NULL;
 527 }
 528
 529
 530 /*********************************************************************
 531     mmap stream functions
 532
 533  Because mmap() is not capable of extending a file, we have to keep
 534  track of how long the file is.  We also have to be able to detect end
 535  of file conditions.  If there are multiple writers to the file (which
 536  can only happen outside the current program), things will get
 537  confused.  Then again, things will get confused anyway.
 538
 539 *********************************************************************/
 540
 541 #if HAVE_MMAP
 542
 543 static int page_size, page_mask;
 544
 545 /* mmap_flush()-- Deletes a memory mapping if something is mapped. */
 546
 547 static try
 548 mmap_flush (unix_stream * s)
 549 {
 550
 551   if (!s->mmaped)
 552     return fd_flush (s);
 553
 554   if (s->buffer == NULL)
 555     return SUCCESS;
 556
 557   if (munmap (s->buffer, s->active))
 558     return FAILURE;
 559
 560   s->buffer = NULL;
 561   s->active = 0;
 562
 563   return SUCCESS;
 564 }
 565
 566
 567 /* mmap_alloc()-- mmap() a section of the file.  The whole section is
 568  * guaranteed to be mappable. */
 569
 570 static try
 571 mmap_alloc (unix_stream * s, gfc_offset where, int *len)
 572 {
 573   gfc_offset offset;
 574   int length;
 575   char *p;
 576
 577   if (mmap_flush (s) == FAILURE)
 578     return FAILURE;
 579
 580   offset = where & page_mask;   /* Round down to the next page */
 581
 582   length = ((where - offset) & page_mask) + 2 * page_size;
 583
 584   p = mmap (NULL, length, s->prot, MAP_SHARED, s->fd, offset);
 585   if (p == (char *) MAP_FAILED)
 586     return FAILURE;
 587
 588   s->mmaped = 1;
 589   s->buffer = p;
 590   s->buffer_offset = offset;
 591   s->active = length;
 592
 593   return SUCCESS;
 594 }
 595
 596
 597 static char *
 598 mmap_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
 599 {
 600   gfc_offset m;
 601
 602   if (where == -1)
 603     where = s->logical_offset;
 604
 605   m = where + *len;
 606
 607   if ((s->buffer == NULL || s->buffer_offset > where ||
 608        m > s->buffer_offset + s->active) &&
 609       mmap_alloc (s, where, len) == FAILURE)
 610     return NULL;
 611
 612   if (m > s->file_length)
 613     {
 614       *len = s->file_length - s->logical_offset;
 615       s->logical_offset = s->file_length;
 616     }
 617   else
 618     s->logical_offset = m;
 619
 620   return s->buffer + (where - s->buffer_offset);
 621 }
 622
 623
 624 static char *
 625 mmap_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
 626 {
 627   if (where == -1)
 628     where = s->logical_offset;
 629
 630   /* If we're extending the file, we have to use file descriptor
 631    * methods. */
 632
 633   if (where + *len > s->file_length)
 634     {
 635       if (s->mmaped)
 636         mmap_flush (s);
 637       return fd_alloc_w_at (s, len, where);
 638     }
 639
 640   if ((s->buffer == NULL || s->buffer_offset > where ||
 641        where + *len > s->buffer_offset + s->active) &&
 642       mmap_alloc (s, where, len) == FAILURE)
 643     return NULL;
 644
 645   s->logical_offset = where + *len;
 646
 647   return s->buffer + where - s->buffer_offset;
 648 }
 649
 650
 651 static int
 652 mmap_seek (unix_stream * s, gfc_offset offset)
 653 {
 654
 655   s->logical_offset = offset;
 656   return SUCCESS;
 657 }
 658
 659
 660 static try
 661 mmap_close (unix_stream * s)
 662 {
 663   try t;
 664
 665   t = mmap_flush (s);
 666
 667   if (close (s->fd) < 0)
 668     t = FAILURE;
 669   free_mem (s);
 670
 671   return t;
 672 }
 673
 674
 675 static try
 676 mmap_sfree (unix_stream * s)
 677 {
 678
 679   return SUCCESS;
 680 }
 681
 682
 683 /* mmap_open()-- mmap_specific open.  If the particular file cannot be
 684  * mmap()-ed, we fall back to the file descriptor functions. */
 685
 686 static try
 687 mmap_open (unix_stream * s)
 688 {
 689   char *p;
 690   int i;
 691
 692   page_size = getpagesize ();
 693   page_mask = ~0;
 694
 695   p = mmap (0, page_size, s->prot, MAP_SHARED, s->fd, 0);
 696   if (p == (char *) MAP_FAILED)
 697     {
 698       fd_open (s);
 699       return SUCCESS;
 700     }
 701
 702   munmap (p, page_size);
 703
 704   i = page_size >> 1;
 705   while (i != 0)
 706     {
 707       page_mask <<= 1;
 708       i >>= 1;
 709     }
 710
 711   s->st.alloc_r_at = (void *) mmap_alloc_r_at;
 712   s->st.alloc_w_at = (void *) mmap_alloc_w_at;
 713   s->st.sfree = (void *) mmap_sfree;
 714   s->st.close = (void *) mmap_close;
 715   s->st.seek = (void *) mmap_seek;
 716   s->st.truncate = (void *) fd_truncate;
 717
 718   if (lseek (s->fd, s->file_length, SEEK_SET) < 0)
 719     return FAILURE;
 720
 721   return SUCCESS;
 722 }
 723
 724 #endif
 725
 726
 727 /*********************************************************************
 728   memory stream functions - These are used for internal files
 729
 730   The idea here is that a single stream structure is created and all
 731   requests must be satisfied from it.  The location and size of the
 732   buffer is the character variable supplied to the READ or WRITE
 733   statement.
 734
 735 *********************************************************************/
 736
 737
 738 static char *
 739 mem_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
 740 {
 741   gfc_offset n;
 742
 743   if (where == -1)
 744     where = s->logical_offset;
 745
 746   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 747     return NULL;
 748
 749   s->logical_offset = where + *len;
 750
 751   n = s->buffer_offset + s->active - where;
 752   if (*len > n)
 753     *len = n;
 754
 755   return s->buffer + (where - s->buffer_offset);
 756 }
 757
 758
 759 static char *
 760 mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
 761 {
 762   gfc_offset m;
 763
 764   if (where == -1)
 765     where = s->logical_offset;
 766
 767   m = where + *len;
 768
 769   if (where < s->buffer_offset || m > s->buffer_offset + s->active)
 770     return NULL;
 771
 772   s->logical_offset = m;
 773
 774   return s->buffer + (where - s->buffer_offset);
 775 }
 776
 777
 778 static int
 779 mem_seek (unix_stream * s, gfc_offset offset)
 780 {
 781
 782   if (offset > s->file_length)
 783     {
 784       errno = ESPIPE;
 785       return FAILURE;
 786     }
 787
 788   s->logical_offset = offset;
 789   return SUCCESS;
 790 }
 791
 792
 793 static int
 794 mem_truncate (unix_stream * s)
 795 {
 796
 797   return SUCCESS;
 798 }
 799
 800
 801 static try
 802 mem_close (unix_stream * s)
 803 {
 804
 805   return SUCCESS;
 806 }
 807
 808
 809 static try
 810 mem_sfree (unix_stream * s)
 811 {
 812
 813   return SUCCESS;
 814 }
 815
 816
 817
 818 /*********************************************************************
 819   Public functions -- A reimplementation of this module needs to
 820   define functional equivalents of the following.
 821 *********************************************************************/
 822
 823 /* empty_internal_buffer()-- Zero the buffer of Internal file */
 824
 825 void
 826 empty_internal_buffer(stream *strm)
 827 {
 828    unix_stream * s = (unix_stream *) strm;
 829    memset(s->buffer, ' ', s->file_length);
 830 }
 831
 832 /* open_internal()-- Returns a stream structure from an internal file */
 833
 834 stream *
 835 open_internal (char *base, int length)
 836 {
 837   unix_stream *s;
 838
 839   s = get_mem (sizeof (unix_stream));
 840
 841   s->buffer = base;
 842   s->buffer_offset = 0;
 843
 844   s->logical_offset = 0;
 845   s->active = s->file_length = length;
 846
 847   s->st.alloc_r_at = (void *) mem_alloc_r_at;
 848   s->st.alloc_w_at = (void *) mem_alloc_w_at;
 849   s->st.sfree = (void *) mem_sfree;
 850   s->st.close = (void *) mem_close;
 851   s->st.seek = (void *) mem_seek;
 852   s->st.truncate = (void *) mem_truncate;
 853
 854   return (stream *) s;
 855 }
 856
 857
 858 /* fd_to_stream()-- Given an open file descriptor, build a stream
 859  * around it. */
 860
 861 static stream *
 862 fd_to_stream (int fd, int prot)
 863 {
 864   struct stat statbuf;
 865   unix_stream *s;
 866
 867   s = get_mem (sizeof (unix_stream));
 868
 869   s->fd = fd;
 870   s->buffer_offset = 0;
 871   s->physical_offset = 0;
 872   s->logical_offset = 0;
 873   s->prot = prot;
 874
 875   /* Get the current length of the file. */
 876
 877   fstat (fd, &statbuf);
 878   s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
 879
 880 #if HAVE_MMAP
 881   mmap_open (s);
 882 #else
 883   fd_open (s);
 884 #endif
 885
 886   return (stream *) s;
 887 }
 888
 889
 890 /* unpack_filename()-- Given a fortran string and a pointer to a
 891  * buffer that is PATH_MAX characters, convert the fortran string to a
 892  * C string in the buffer.  Returns nonzero if this is not possible.  */
 893
 894 static int
 895 unpack_filename (char *cstring, const char *fstring, int len)
 896 {
 897
 898   len = fstrlen (fstring, len);
 899   if (len >= PATH_MAX)
 900     return 1;
 901
 902   memmove (cstring, fstring, len);
 903   cstring[len] = '\0';
 904
 905   return 0;
 906 }
 907
 908
 909 /* tempfile()-- Generate a temporary filename for a scratch file and
 910  * open it.  mkstemp() opens the file for reading and writing, but the
 911  * library mode prevents anything that is not allowed.  The descriptor
 912  * is returns, which is less than zero on error.  The template is
 913  * pointed to by ioparm.file, which is copied into the unit structure
 914  * and freed later. */
 915
 916 static int
 917 tempfile (void)
 918 {
 919   const char *tempdir;
 920   char *template;
 921   int fd;
 922
 923   tempdir = getenv ("GFORTRAN_TMPDIR");
 924   if (tempdir == NULL)
 925     tempdir = getenv ("TMP");
 926   if (tempdir == NULL)
 927     tempdir = DEFAULT_TEMPDIR;
 928
 929   template = get_mem (strlen (tempdir) + 20);
 930
 931   st_sprintf (template, "%s/gfortantmpXXXXXX", tempdir);
 932
 933   fd = mkstemp (template);
 934
 935   if (fd < 0)
 936     free_mem (template);
 937   else
 938     {
 939       ioparm.file = template;
 940       ioparm.file_len = strlen (template);      /* Don't include trailing nul */
 941     }
 942
 943   return fd;
 944 }
 945
 946
 947 /* regular_file()-- Open a regular file.  Returns the descriptor, which is less than zero on error. */
 948
 949 static int
 950 regular_file (unit_action action, unit_status status)
 951 {
 952   char path[PATH_MAX + 1];
 953   struct stat statbuf;
 954   int mode;
 955
 956   if (unpack_filename (path, ioparm.file, ioparm.file_len))
 957     {
 958       errno = ENOENT;           /* Fake an OS error */
 959       return -1;
 960     }
 961
 962   mode = 0;
 963
 964   switch (action)
 965     {
 966     case ACTION_READ:
 967       mode = O_RDONLY;
 968       break;
 969
 970     case ACTION_WRITE:
 971       mode = O_WRONLY;
 972       break;
 973
 974     case ACTION_READWRITE:
 975       mode = O_RDWR;
 976       break;
 977
 978     default:
 979       internal_error ("regular_file(): Bad action");
 980     }
 981
 982   switch (status)
 983     {
 984     case STATUS_NEW:
 985       mode |= O_CREAT | O_EXCL;
 986       break;
 987
 988     case STATUS_OLD:            /* file must exist, so check for its existence */
 989       if (stat (path, &statbuf) < 0)
 990         return -1;
 991       break;
 992
 993     case STATUS_UNKNOWN:
 994     case STATUS_SCRATCH:
 995       mode |= O_CREAT;
 996       break;
 997
 998     case STATUS_REPLACE:
 999         mode |= O_CREAT | O_TRUNC;
1000       break;
1001
1002     default:
1003       internal_error ("regular_file(): Bad status");
1004     }
1005
1006   // mode |= O_LARGEFILE;
1007
1008   return open (path, mode,
1009                S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH);
1010 }
1011
1012
1013 /* open_external()-- Open an external file, unix specific version.
1014  * Returns NULL on operating system error. */
1015
1016 stream *
1017 open_external (unit_action action, unit_status status)
1018 {
1019   int fd, prot;
1020
1021   fd =
1022     (status == STATUS_SCRATCH) ? tempfile () : regular_file (action, status);
1023
1024   if (fd < 0)
1025     return NULL;
1026   fd = fix_fd (fd);
1027
1028   switch (action)
1029     {
1030     case ACTION_READ:
1031       prot = PROT_READ;
1032       break;
1033
1034     case ACTION_WRITE:
1035       prot = PROT_WRITE;
1036       break;
1037
1038     case ACTION_READWRITE:
1039       prot = PROT_READ | PROT_WRITE;
1040       break;
1041
1042     default:
1043       internal_error ("open_external(): Bad action");
1044     }
1045
1046   /* If this is a scratch file, we can unlink it now and the file will
1047    * go away when it is closed. */
1048
1049   if (status == STATUS_SCRATCH)
1050     unlink (ioparm.file);
1051
1052   return fd_to_stream (fd, prot);
1053 }
1054
1055
1056 /* input_stream()-- Return a stream pointer to the default input stream.
1057  * Called on initialization. */
1058
1059 stream *
1060 input_stream (void)
1061 {
1062
1063   return fd_to_stream (STDIN_FILENO, PROT_READ);
1064 }
1065
1066
1067 /* output_stream()-- Return a stream pointer to the default input stream.
1068  * Called on initialization. */
1069
1070 stream *
1071 output_stream (void)
1072 {
1073
1074   return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1075 }
1076
1077
1078 /* init_error_stream()-- Return a pointer to the error stream.  This
1079  * subroutine is called when the stream is needed, rather than at
1080  * initialization.  We want to work even if memory has been seriously
1081  * corrupted. */
1082
1083 stream *
1084 init_error_stream (void)
1085 {
1086   static unix_stream error;
1087
1088   memset (&error, '\0', sizeof (error));
1089
1090   error.fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1091
1092   error.st.alloc_w_at = (void *) fd_alloc_w_at;
1093   error.st.sfree = (void *) fd_sfree;
1094
1095   error.unbuffered = 1;
1096   error.buffer = error.small_buffer;
1097
1098   return (stream *) & error;
1099 }
1100
1101
1102 /* compare_file_filename()-- Given an open stream and a fortran string
1103  * that is a filename, figure out if the file is the same as the
1104  * filename. */
1105
1106 int
1107 compare_file_filename (stream * s, const char *name, int len)
1108 {
1109   char path[PATH_MAX + 1];
1110   struct stat st1, st2;
1111
1112   if (unpack_filename (path, name, len))
1113     return 0;                   /* Can't be the same */
1114
1115   /* If the filename doesn't exist, then there is no match with the
1116    * existing file. */
1117
1118   if (stat (path, &st1) < 0)
1119     return 0;
1120
1121   fstat (((unix_stream *) s)->fd, &st2);
1122
1123   return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1124 }
1125
1126
1127 /* find_file0()-- Recursive work function for find_file() */
1128
1129 static gfc_unit *
1130 find_file0 (gfc_unit * u, struct stat *st1)
1131 {
1132   struct stat st2;
1133   gfc_unit *v;
1134
1135   if (u == NULL)
1136     return NULL;
1137
1138   if (fstat (((unix_stream *) u->s)->fd, &st2) >= 0 &&
1139       st1->st_dev == st2.st_dev && st1->st_ino == st2.st_ino)
1140     return u;
1141
1142   v = find_file0 (u->left, st1);
1143   if (v != NULL)
1144     return v;
1145
1146   v = find_file0 (u->right, st1);
1147   if (v != NULL)
1148     return v;
1149
1150   return NULL;
1151 }
1152
1153
1154 /* find_file()-- Take the current filename and see if there is a unit
1155  * that has the file already open.  Returns a pointer to the unit if so. */
1156
1157 gfc_unit *
1158 find_file (void)
1159 {
1160   char path[PATH_MAX + 1];
1161   struct stat statbuf;
1162
1163   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1164     return NULL;
1165
1166   if (stat (path, &statbuf) < 0)
1167     return NULL;
1168
1169   return find_file0 (g.unit_root, &statbuf);
1170 }
1171
1172
1173 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1174  * of the file. */
1175
1176 int
1177 stream_at_bof (stream * s)
1178 {
1179   unix_stream *us;
1180
1181   us = (unix_stream *) s;
1182
1183   if (!us->mmaped)
1184     return 0;                   /* File is not seekable */
1185
1186   return us->logical_offset == 0;
1187 }
1188
1189
1190 /* stream_at_eof()-- Returns nonzero if the stream is at the beginning
1191  * of the file. */
1192
1193 int
1194 stream_at_eof (stream * s)
1195 {
1196   unix_stream *us;
1197
1198   us = (unix_stream *) s;
1199
1200   if (!us->mmaped)
1201     return 0;                   /* File is not seekable */
1202
1203   return us->logical_offset == us->dirty_offset;
1204 }
1205
1206
1207 /* delete_file()-- Given a unit structure, delete the file associated
1208  * with the unit.  Returns nonzero if something went wrong. */
1209
1210 int
1211 delete_file (gfc_unit * u)
1212 {
1213   char path[PATH_MAX + 1];
1214
1215   if (unpack_filename (path, u->file, u->file_len))
1216     {                           /* Shouldn't be possible */
1217       errno = ENOENT;
1218       return 1;
1219     }
1220
1221   return unlink (path);
1222 }
1223
1224
1225 /* file_exists()-- Returns nonzero if the current filename exists on
1226  * the system */
1227
1228 int
1229 file_exists (void)
1230 {
1231   char path[PATH_MAX + 1];
1232   struct stat statbuf;
1233
1234   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1235     return 0;
1236
1237   if (stat (path, &statbuf) < 0)
1238     return 0;
1239
1240   return 1;
1241 }
1242
1243
1244
1245 static const char *yes = "YES", *no = "NO", *unknown = "UNKNOWN";
1246
1247 /* inquire_sequential()-- Given a fortran string, determine if the
1248  * file is suitable for sequential access.  Returns a C-style
1249  * string. */
1250
1251 const char *
1252 inquire_sequential (const char *string, int len)
1253 {
1254   char path[PATH_MAX + 1];
1255   struct stat statbuf;
1256
1257   if (string == NULL ||
1258       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1259     return unknown;
1260
1261   if (S_ISREG (statbuf.st_mode) ||
1262       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1263     return yes;
1264
1265   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1266     return no;
1267
1268   return unknown;
1269 }
1270
1271
1272 /* inquire_direct()-- Given a fortran string, determine if the file is
1273  * suitable for direct access.  Returns a C-style string. */
1274
1275 const char *
1276 inquire_direct (const char *string, int len)
1277 {
1278   char path[PATH_MAX + 1];
1279   struct stat statbuf;
1280
1281   if (string == NULL ||
1282       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1283     return unknown;
1284
1285   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1286     return yes;
1287
1288   if (S_ISDIR (statbuf.st_mode) ||
1289       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1290     return no;
1291
1292   return unknown;
1293 }
1294
1295
1296 /* inquire_formatted()-- Given a fortran string, determine if the file
1297  * is suitable for formatted form.  Returns a C-style string. */
1298
1299 const char *
1300 inquire_formatted (const char *string, int len)
1301 {
1302   char path[PATH_MAX + 1];
1303   struct stat statbuf;
1304
1305   if (string == NULL ||
1306       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1307     return unknown;
1308
1309   if (S_ISREG (statbuf.st_mode) ||
1310       S_ISBLK (statbuf.st_mode) ||
1311       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1312     return yes;
1313
1314   if (S_ISDIR (statbuf.st_mode))
1315     return no;
1316
1317   return unknown;
1318 }
1319
1320
1321 /* inquire_unformatted()-- Given a fortran string, determine if the file
1322  * is suitable for unformatted form.  Returns a C-style string. */
1323
1324 const char *
1325 inquire_unformatted (const char *string, int len)
1326 {
1327
1328   return inquire_formatted (string, len);
1329 }
1330
1331
1332 /* inquire_access()-- Given a fortran string, determine if the file is
1333  * suitable for access. */
1334
1335 static const char *
1336 inquire_access (const char *string, int len, int mode)
1337 {
1338   char path[PATH_MAX + 1];
1339
1340   if (string == NULL || unpack_filename (path, string, len) ||
1341       access (path, mode) < 0)
1342     return no;
1343
1344   return yes;
1345 }
1346
1347
1348 /* inquire_read()-- Given a fortran string, determine if the file is
1349  * suitable for READ access. */
1350
1351 const char *
1352 inquire_read (const char *string, int len)
1353 {
1354
1355   return inquire_access (string, len, R_OK);
1356 }
1357
1358
1359 /* inquire_write()-- Given a fortran string, determine if the file is
1360  * suitable for READ access. */
1361
1362 const char *
1363 inquire_write (const char *string, int len)
1364 {
1365
1366   return inquire_access (string, len, W_OK);
1367 }
1368
1369
1370 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1371  * suitable for read and write access. */
1372
1373 const char *
1374 inquire_readwrite (const char *string, int len)
1375 {
1376
1377   return inquire_access (string, len, R_OK | W_OK);
1378 }
1379
1380
1381 /* file_length()-- Return the file length in bytes, -1 if unknown */
1382
1383 gfc_offset
1384 file_length (stream * s)
1385 {
1386
1387   return ((unix_stream *) s)->file_length;
1388 }
1389
1390
1391 /* file_position()-- Return the current position of the file */
1392
1393 gfc_offset
1394 file_position (stream * s)
1395 {
1396
1397   return ((unix_stream *) s)->logical_offset;
1398 }
1399
1400
1401 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1402  * it is not */
1403
1404 int
1405 is_seekable (stream * s)
1406 {
1407   /* by convention, if file_length == -1, the file is not seekable
1408      note that a mmapped file is always seekable, an fd_ file may
1409      or may not be. */
1410   return ((unix_stream *) s)->file_length!=-1;
1411 }
1412
1413 try
1414 flush (stream *s)
1415 {
1416   return fd_flush( (unix_stream *) s);
1417 }
1418
1419
1420 /* How files are stored:  This is an operating-system specific issue,
1421    and therefore belongs here.  There are three cases to consider.
1422
1423    Direct Access:
1424       Records are written as block of bytes corresponding to the record
1425       length of the file.  This goes for both formatted and unformatted
1426       records.  Positioning is done explicitly for each data transfer,
1427       so positioning is not much of an issue.
1428
1429    Sequential Formatted:
1430       Records are separated by newline characters.  The newline character
1431       is prohibited from appearing in a string.  If it does, this will be
1432       messed up on the next read.  End of file is also the end of a record.
1433
1434    Sequential Unformatted:
1435       In this case, we are merely copying bytes to and from main storage,
1436       yet we need to keep track of varying record lengths.  We adopt
1437       the solution used by f2c.  Each record contains a pair of length
1438       markers:
1439
1440         Length of record n in bytes
1441         Data of record n
1442         Length of record n in bytes
1443
1444         Length of record n+1 in bytes
1445         Data of record n+1
1446         Length of record n+1 in bytes
1447
1448      The length is stored at the end of a record to allow backspacing to the
1449      previous record.  Between data transfer statements, the file pointer
1450      is left pointing to the first length of the current record.
1451
1452      ENDFILE records are never explicitly stored.
1453
1454 */