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