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