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 #ifdef HAVE_FTRUNCATE
 517   if (ftruncate (s->fd, s->logical_offset))
 518     return FAILURE;
 519 #else
 520 #ifdef HAVE_CHSIZE
 521   if (chsize (s->fd, s->logical_offset))
 522     return FAILURE;
 523 #endif
 524 #endif
 525
 526   s->physical_offset = s->file_length = s->logical_offset;
 527
 528   return SUCCESS;
 529 }
 530
 531
 532 static try
 533 fd_close (unix_stream * s)
 534 {
 535   if (fd_flush (s) == FAILURE)
 536     return FAILURE;
 537
 538   if (s->buffer != NULL && s->buffer != s->small_buffer)
 539     free_mem (s->buffer);
 540
 541   if (close (s->fd) < 0)
 542     return FAILURE;
 543
 544   free_mem (s);
 545
 546   return SUCCESS;
 547 }
 548
 549
 550 static void
 551 fd_open (unix_stream * s)
 552 {
 553   if (isatty (s->fd))
 554     s->unbuffered = 1;
 555
 556   s->st.alloc_r_at = (void *) fd_alloc_r_at;
 557   s->st.alloc_w_at = (void *) fd_alloc_w_at;
 558   s->st.sfree = (void *) fd_sfree;
 559   s->st.close = (void *) fd_close;
 560   s->st.seek = (void *) fd_seek;
 561   s->st.truncate = (void *) fd_truncate;
 562
 563   s->buffer = NULL;
 564 }
 565
 566
 567 /*********************************************************************
 568     mmap stream functions
 569
 570  Because mmap() is not capable of extending a file, we have to keep
 571  track of how long the file is.  We also have to be able to detect end
 572  of file conditions.  If there are multiple writers to the file (which
 573  can only happen outside the current program), things will get
 574  confused.  Then again, things will get confused anyway.
 575
 576 *********************************************************************/
 577
 578 #if HAVE_MMAP
 579
 580 static int page_size, page_mask;
 581
 582 /* mmap_flush()-- Deletes a memory mapping if something is mapped. */
 583
 584 static try
 585 mmap_flush (unix_stream * s)
 586 {
 587   if (!s->mmaped)
 588     return fd_flush (s);
 589
 590   if (s->buffer == NULL)
 591     return SUCCESS;
 592
 593   if (munmap (s->buffer, s->active))
 594     return FAILURE;
 595
 596   s->buffer = NULL;
 597   s->active = 0;
 598
 599   return SUCCESS;
 600 }
 601
 602
 603 /* mmap_alloc()-- mmap() a section of the file.  The whole section is
 604  * guaranteed to be mappable. */
 605
 606 static try
 607 mmap_alloc (unix_stream * s, gfc_offset where, int *len)
 608 {
 609   gfc_offset offset;
 610   int length;
 611   char *p;
 612
 613   if (mmap_flush (s) == FAILURE)
 614     return FAILURE;
 615
 616   offset = where & page_mask;   /* Round down to the next page */
 617
 618   length = ((where - offset) & page_mask) + 2 * page_size;
 619
 620   p = mmap (NULL, length, s->prot, MAP_SHARED, s->fd, offset);
 621   if (p == (char *) MAP_FAILED)
 622     return FAILURE;
 623
 624   s->mmaped = 1;
 625   s->buffer = p;
 626   s->buffer_offset = offset;
 627   s->active = length;
 628
 629   return SUCCESS;
 630 }
 631
 632
 633 static char *
 634 mmap_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
 635 {
 636   gfc_offset m;
 637
 638   if (where == -1)
 639     where = s->logical_offset;
 640
 641   m = where + *len;
 642
 643   if ((s->buffer == NULL || s->buffer_offset > where ||
 644        m > s->buffer_offset + s->active) &&
 645       mmap_alloc (s, where, len) == FAILURE)
 646     return NULL;
 647
 648   if (m > s->file_length)
 649     {
 650       *len = s->file_length - s->logical_offset;
 651       s->logical_offset = s->file_length;
 652     }
 653   else
 654     s->logical_offset = m;
 655
 656   return s->buffer + (where - s->buffer_offset);
 657 }
 658
 659
 660 static char *
 661 mmap_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
 662 {
 663   if (where == -1)
 664     where = s->logical_offset;
 665
 666   /* If we're extending the file, we have to use file descriptor
 667    * methods. */
 668
 669   if (where + *len > s->file_length)
 670     {
 671       if (s->mmaped)
 672         mmap_flush (s);
 673       return fd_alloc_w_at (s, len, where);
 674     }
 675
 676   if ((s->buffer == NULL || s->buffer_offset > where ||
 677        where + *len > s->buffer_offset + s->active ||
 678        where < s->buffer_offset + s->active) &&
 679       mmap_alloc (s, where, len) == FAILURE)
 680     return NULL;
 681
 682   s->logical_offset = where + *len;
 683
 684   return s->buffer + where - s->buffer_offset;
 685 }
 686
 687
 688 static int
 689 mmap_seek (unix_stream * s, gfc_offset offset)
 690 {
 691   s->logical_offset = offset;
 692   return SUCCESS;
 693 }
 694
 695
 696 static try
 697 mmap_close (unix_stream * s)
 698 {
 699   try t;
 700
 701   t = mmap_flush (s);
 702
 703   if (close (s->fd) < 0)
 704     t = FAILURE;
 705   free_mem (s);
 706
 707   return t;
 708 }
 709
 710
 711 static try
 712 mmap_sfree (unix_stream * s)
 713 {
 714   return SUCCESS;
 715 }
 716
 717
 718 /* mmap_open()-- mmap_specific open.  If the particular file cannot be
 719  * mmap()-ed, we fall back to the file descriptor functions. */
 720
 721 static try
 722 mmap_open (unix_stream * s)
 723 {
 724   char *p;
 725   int i;
 726
 727   page_size = getpagesize ();
 728   page_mask = ~0;
 729
 730   p = mmap (0, page_size, s->prot, MAP_SHARED, s->fd, 0);
 731   if (p == (char *) MAP_FAILED)
 732     {
 733       fd_open (s);
 734       return SUCCESS;
 735     }
 736
 737   munmap (p, page_size);
 738
 739   i = page_size >> 1;
 740   while (i != 0)
 741     {
 742       page_mask <<= 1;
 743       i >>= 1;
 744     }
 745
 746   s->st.alloc_r_at = (void *) mmap_alloc_r_at;
 747   s->st.alloc_w_at = (void *) mmap_alloc_w_at;
 748   s->st.sfree = (void *) mmap_sfree;
 749   s->st.close = (void *) mmap_close;
 750   s->st.seek = (void *) mmap_seek;
 751   s->st.truncate = (void *) fd_truncate;
 752
 753   if (lseek (s->fd, s->file_length, SEEK_SET) < 0)
 754     return FAILURE;
 755
 756   return SUCCESS;
 757 }
 758
 759 #endif
 760
 761
 762 /*********************************************************************
 763   memory stream functions - These are used for internal files
 764
 765   The idea here is that a single stream structure is created and all
 766   requests must be satisfied from it.  The location and size of the
 767   buffer is the character variable supplied to the READ or WRITE
 768   statement.
 769
 770 *********************************************************************/
 771
 772
 773 static char *
 774 mem_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
 775 {
 776   gfc_offset n;
 777
 778   if (where == -1)
 779     where = s->logical_offset;
 780
 781   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 782     return NULL;
 783
 784   s->logical_offset = where + *len;
 785
 786   n = s->buffer_offset + s->active - where;
 787   if (*len > n)
 788     *len = n;
 789
 790   return s->buffer + (where - s->buffer_offset);
 791 }
 792
 793
 794 static char *
 795 mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
 796 {
 797   gfc_offset m;
 798
 799   if (where == -1)
 800     where = s->logical_offset;
 801
 802   m = where + *len;
 803
 804   if (where < s->buffer_offset || m > s->buffer_offset + s->active)
 805     return NULL;
 806
 807   s->logical_offset = m;
 808
 809   return s->buffer + (where - s->buffer_offset);
 810 }
 811
 812
 813 static int
 814 mem_seek (unix_stream * s, gfc_offset offset)
 815 {
 816   if (offset > s->file_length)
 817     {
 818       errno = ESPIPE;
 819       return FAILURE;
 820     }
 821
 822   s->logical_offset = offset;
 823   return SUCCESS;
 824 }
 825
 826
 827 static int
 828 mem_truncate (unix_stream * s)
 829 {
 830   return SUCCESS;
 831 }
 832
 833
 834 static try
 835 mem_close (unix_stream * s)
 836 {
 837   free_mem (s);
 838
 839   return SUCCESS;
 840 }
 841
 842
 843 static try
 844 mem_sfree (unix_stream * s)
 845 {
 846   return SUCCESS;
 847 }
 848
 849
 850
 851 /*********************************************************************
 852   Public functions -- A reimplementation of this module needs to
 853   define functional equivalents of the following.
 854 *********************************************************************/
 855
 856 /* empty_internal_buffer()-- Zero the buffer of Internal file */
 857
 858 void
 859 empty_internal_buffer(stream *strm)
 860 {
 861   unix_stream * s = (unix_stream *) strm;
 862   memset(s->buffer, ' ', s->file_length);
 863 }
 864
 865 /* open_internal()-- Returns a stream structure from an internal file */
 866
 867 stream *
 868 open_internal (char *base, int length)
 869 {
 870   unix_stream *s;
 871
 872   s = get_mem (sizeof (unix_stream));
 873
 874   s->buffer = base;
 875   s->buffer_offset = 0;
 876
 877   s->logical_offset = 0;
 878   s->active = s->file_length = length;
 879
 880   s->st.alloc_r_at = (void *) mem_alloc_r_at;
 881   s->st.alloc_w_at = (void *) mem_alloc_w_at;
 882   s->st.sfree = (void *) mem_sfree;
 883   s->st.close = (void *) mem_close;
 884   s->st.seek = (void *) mem_seek;
 885   s->st.truncate = (void *) mem_truncate;
 886
 887   return (stream *) s;
 888 }
 889
 890
 891 /* fd_to_stream()-- Given an open file descriptor, build a stream
 892  * around it. */
 893
 894 static stream *
 895 fd_to_stream (int fd, int prot, int avoid_mmap)
 896 {
 897   struct stat statbuf;
 898   unix_stream *s;
 899
 900   s = get_mem (sizeof (unix_stream));
 901
 902   s->fd = fd;
 903   s->buffer_offset = 0;
 904   s->physical_offset = 0;
 905   s->logical_offset = 0;
 906   s->prot = prot;
 907
 908   /* Get the current length of the file. */
 909
 910   fstat (fd, &statbuf);
 911   s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
 912
 913 #if HAVE_MMAP
 914   if (avoid_mmap)
 915     fd_open (s);
 916   else
 917     mmap_open (s);
 918 #else
 919   fd_open (s);
 920 #endif
 921
 922   return (stream *) s;
 923 }
 924
 925
 926 /* Given the Fortran unit number, convert it to a C file descriptor.  */
 927
 928 int
 929 unit_to_fd(int unit)
 930 {
 931   gfc_unit *us;
 932
 933   us = find_unit(unit);
 934   if (us == NULL)
 935     return -1;
 936
 937   return ((unix_stream *) us->s)->fd;
 938 }
 939
 940
 941 /* unpack_filename()-- Given a fortran string and a pointer to a
 942  * buffer that is PATH_MAX characters, convert the fortran string to a
 943  * C string in the buffer.  Returns nonzero if this is not possible.  */
 944
 945 static int
 946 unpack_filename (char *cstring, const char *fstring, int len)
 947 {
 948   len = fstrlen (fstring, len);
 949   if (len >= PATH_MAX)
 950     return 1;
 951
 952   memmove (cstring, fstring, len);
 953   cstring[len] = '\0';
 954
 955   return 0;
 956 }
 957
 958
 959 /* tempfile()-- Generate a temporary filename for a scratch file and
 960  * open it.  mkstemp() opens the file for reading and writing, but the
 961  * library mode prevents anything that is not allowed.  The descriptor
 962  * is returned, which is -1 on error.  The template is pointed to by
 963  * ioparm.file, which is copied into the unit structure
 964  * and freed later. */
 965
 966 static int
 967 tempfile (void)
 968 {
 969   const char *tempdir;
 970   char *template;
 971   int fd;
 972
 973   tempdir = getenv ("GFORTRAN_TMPDIR");
 974   if (tempdir == NULL)
 975     tempdir = getenv ("TMP");
 976   if (tempdir == NULL)
 977     tempdir = DEFAULT_TEMPDIR;
 978
 979   template = get_mem (strlen (tempdir) + 20);
 980
 981   st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
 982
 983 #ifdef HAVE_MKSTEMP
 984
 985   fd = mkstemp (template);
 986
 987 #else /* HAVE_MKSTEMP */
 988
 989   if (mktemp (template))
 990     do
 991       fd = open (template, O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
 992     while (!(fd == -1 && errno == EEXIST) && mktemp (template));
 993   else
 994     fd = -1;
 995
 996 #endif /* HAVE_MKSTEMP */
 997
 998   if (fd < 0)
 999     free_mem (template);
1000   else
1001     {
1002       ioparm.file = template;
1003       ioparm.file_len = strlen (template);      /* Don't include trailing nul */
1004     }
1005
1006   return fd;
1007 }
1008
1009
1010 /* regular_file()-- Open a regular file.
1011  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1012  * unless an error occurs.
1013  * Returns the descriptor, which is less than zero on error. */
1014
1015 static int
1016 regular_file (unit_flags *flags)
1017 {
1018   char path[PATH_MAX + 1];
1019   int mode;
1020   int rwflag;
1021   int crflag;
1022   int fd;
1023
1024   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1025     {
1026       errno = ENOENT;           /* Fake an OS error */
1027       return -1;
1028     }
1029
1030   rwflag = 0;
1031
1032   switch (flags->action)
1033     {
1034     case ACTION_READ:
1035       rwflag = O_RDONLY;
1036       break;
1037
1038     case ACTION_WRITE:
1039       rwflag = O_WRONLY;
1040       break;
1041
1042     case ACTION_READWRITE:
1043     case ACTION_UNSPECIFIED:
1044       rwflag = O_RDWR;
1045       break;
1046
1047     default:
1048       internal_error ("regular_file(): Bad action");
1049     }
1050
1051   switch (flags->status)
1052     {
1053     case STATUS_NEW:
1054       crflag = O_CREAT | O_EXCL;
1055       break;
1056
1057     case STATUS_OLD:            /* open will fail if the file does not exist*/
1058       crflag = 0;
1059       break;
1060
1061     case STATUS_UNKNOWN:
1062     case STATUS_SCRATCH:
1063       crflag = O_CREAT;
1064       break;
1065
1066     case STATUS_REPLACE:
1067         crflag = O_CREAT | O_TRUNC;
1068       break;
1069
1070     default:
1071       internal_error ("regular_file(): Bad status");
1072     }
1073
1074   /* rwflag |= O_LARGEFILE; */
1075
1076   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1077   fd = open (path, rwflag | crflag, mode);
1078   if (flags->action != ACTION_UNSPECIFIED)
1079       return fd;
1080
1081   if (fd >= 0)
1082     {
1083       flags->action = ACTION_READWRITE;
1084       return fd;
1085     }
1086   if (errno != EACCES)
1087      return fd;
1088
1089   /* retry for read-only access */
1090   rwflag = O_RDONLY;
1091   fd = open (path, rwflag | crflag, mode);
1092   if (fd >=0)
1093     {
1094       flags->action = ACTION_READ;
1095       return fd;               /* success */
1096     }
1097
1098   if (errno != EACCES)
1099     return fd;                 /* failure */
1100
1101   /* retry for write-only access */
1102   rwflag = O_WRONLY;
1103   fd = open (path, rwflag | crflag, mode);
1104   if (fd >=0)
1105     {
1106       flags->action = ACTION_WRITE;
1107       return fd;               /* success */
1108     }
1109   return fd;                   /* failure */
1110 }
1111
1112
1113 /* open_external()-- Open an external file, unix specific version.
1114  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1115  * Returns NULL on operating system error. */
1116
1117 stream *
1118 open_external (unit_flags *flags)
1119 {
1120   int fd, prot;
1121
1122   if (flags->status == STATUS_SCRATCH)
1123     {
1124       fd = tempfile ();
1125       if (flags->action == ACTION_UNSPECIFIED)
1126         flags->action = ACTION_READWRITE;
1127       /* We can unlink scratch files now and it will go away when closed. */
1128       unlink (ioparm.file);
1129     }
1130   else
1131     {
1132       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1133        * if it succeeds */
1134       fd = regular_file (flags);
1135     }
1136
1137   if (fd < 0)
1138     return NULL;
1139   fd = fix_fd (fd);
1140
1141   switch (flags->action)
1142     {
1143     case ACTION_READ:
1144       prot = PROT_READ;
1145       break;
1146
1147     case ACTION_WRITE:
1148       prot = PROT_WRITE;
1149       break;
1150
1151     case ACTION_READWRITE:
1152       prot = PROT_READ | PROT_WRITE;
1153       break;
1154
1155     default:
1156       internal_error ("open_external(): Bad action");
1157     }
1158
1159   return fd_to_stream (fd, prot, 0);
1160 }
1161
1162
1163 /* input_stream()-- Return a stream pointer to the default input stream.
1164  * Called on initialization. */
1165
1166 stream *
1167 input_stream (void)
1168 {
1169   return fd_to_stream (STDIN_FILENO, PROT_READ, 1);
1170 }
1171
1172
1173 /* output_stream()-- Return a stream pointer to the default output stream.
1174  * Called on initialization. */
1175
1176 stream *
1177 output_stream (void)
1178 {
1179   return fd_to_stream (STDOUT_FILENO, PROT_WRITE, 1);
1180 }
1181
1182
1183 /* error_stream()-- Return a stream pointer to the default error stream.
1184  * Called on initialization. */
1185
1186 stream *
1187 error_stream (void)
1188 {
1189   return fd_to_stream (STDERR_FILENO, PROT_WRITE, 1);
1190 }
1191
1192 /* init_error_stream()-- Return a pointer to the error stream.  This
1193  * subroutine is called when the stream is needed, rather than at
1194  * initialization.  We want to work even if memory has been seriously
1195  * corrupted. */
1196
1197 stream *
1198 init_error_stream (void)
1199 {
1200   static unix_stream error;
1201
1202   memset (&error, '\0', sizeof (error));
1203
1204   error.fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1205
1206   error.st.alloc_w_at = (void *) fd_alloc_w_at;
1207   error.st.sfree = (void *) fd_sfree;
1208
1209   error.unbuffered = 1;
1210   error.buffer = error.small_buffer;
1211
1212   return (stream *) & error;
1213 }
1214
1215
1216 /* compare_file_filename()-- Given an open stream and a fortran string
1217  * that is a filename, figure out if the file is the same as the
1218  * filename. */
1219
1220 int
1221 compare_file_filename (stream * s, const char *name, int len)
1222 {
1223   char path[PATH_MAX + 1];
1224   struct stat st1, st2;
1225
1226   if (unpack_filename (path, name, len))
1227     return 0;                   /* Can't be the same */
1228
1229   /* If the filename doesn't exist, then there is no match with the
1230    * existing file. */
1231
1232   if (stat (path, &st1) < 0)
1233     return 0;
1234
1235   fstat (((unix_stream *) s)->fd, &st2);
1236
1237   return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1238 }
1239
1240
1241 /* find_file0()-- Recursive work function for find_file() */
1242
1243 static gfc_unit *
1244 find_file0 (gfc_unit * u, struct stat *st1)
1245 {
1246   struct stat st2;
1247   gfc_unit *v;
1248
1249   if (u == NULL)
1250     return NULL;
1251
1252   if (fstat (((unix_stream *) u->s)->fd, &st2) >= 0 &&
1253       st1->st_dev == st2.st_dev && st1->st_ino == st2.st_ino)
1254     return u;
1255
1256   v = find_file0 (u->left, st1);
1257   if (v != NULL)
1258     return v;
1259
1260   v = find_file0 (u->right, st1);
1261   if (v != NULL)
1262     return v;
1263
1264   return NULL;
1265 }
1266
1267
1268 /* find_file()-- Take the current filename and see if there is a unit
1269  * that has the file already open.  Returns a pointer to the unit if so. */
1270
1271 gfc_unit *
1272 find_file (void)
1273 {
1274   char path[PATH_MAX + 1];
1275   struct stat statbuf;
1276
1277   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1278     return NULL;
1279
1280   if (stat (path, &statbuf) < 0)
1281     return NULL;
1282
1283   return find_file0 (g.unit_root, &statbuf);
1284 }
1285
1286
1287 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1288  * of the file. */
1289
1290 int
1291 stream_at_bof (stream * s)
1292 {
1293   unix_stream *us;
1294
1295   us = (unix_stream *) s;
1296
1297   if (!us->mmaped)
1298     return 0;                   /* File is not seekable */
1299
1300   return us->logical_offset == 0;
1301 }
1302
1303
1304 /* stream_at_eof()-- Returns nonzero if the stream is at the beginning
1305  * of the file. */
1306
1307 int
1308 stream_at_eof (stream * s)
1309 {
1310   unix_stream *us;
1311
1312   us = (unix_stream *) s;
1313
1314   if (!us->mmaped)
1315     return 0;                   /* File is not seekable */
1316
1317   return us->logical_offset == us->dirty_offset;
1318 }
1319
1320
1321 /* delete_file()-- Given a unit structure, delete the file associated
1322  * with the unit.  Returns nonzero if something went wrong. */
1323
1324 int
1325 delete_file (gfc_unit * u)
1326 {
1327   char path[PATH_MAX + 1];
1328
1329   if (unpack_filename (path, u->file, u->file_len))
1330     {                           /* Shouldn't be possible */
1331       errno = ENOENT;
1332       return 1;
1333     }
1334
1335   return unlink (path);
1336 }
1337
1338
1339 /* file_exists()-- Returns nonzero if the current filename exists on
1340  * the system */
1341
1342 int
1343 file_exists (void)
1344 {
1345   char path[PATH_MAX + 1];
1346   struct stat statbuf;
1347
1348   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1349     return 0;
1350
1351   if (stat (path, &statbuf) < 0)
1352     return 0;
1353
1354   return 1;
1355 }
1356
1357
1358
1359 static const char *yes = "YES", *no = "NO", *unknown = "UNKNOWN";
1360
1361 /* inquire_sequential()-- Given a fortran string, determine if the
1362  * file is suitable for sequential access.  Returns a C-style
1363  * string. */
1364
1365 const char *
1366 inquire_sequential (const char *string, int len)
1367 {
1368   char path[PATH_MAX + 1];
1369   struct stat statbuf;
1370
1371   if (string == NULL ||
1372       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1373     return unknown;
1374
1375   if (S_ISREG (statbuf.st_mode) ||
1376       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1377     return yes;
1378
1379   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1380     return no;
1381
1382   return unknown;
1383 }
1384
1385
1386 /* inquire_direct()-- Given a fortran string, determine if the file is
1387  * suitable for direct access.  Returns a C-style string. */
1388
1389 const char *
1390 inquire_direct (const char *string, int len)
1391 {
1392   char path[PATH_MAX + 1];
1393   struct stat statbuf;
1394
1395   if (string == NULL ||
1396       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1397     return unknown;
1398
1399   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1400     return yes;
1401
1402   if (S_ISDIR (statbuf.st_mode) ||
1403       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1404     return no;
1405
1406   return unknown;
1407 }
1408
1409
1410 /* inquire_formatted()-- Given a fortran string, determine if the file
1411  * is suitable for formatted form.  Returns a C-style string. */
1412
1413 const char *
1414 inquire_formatted (const char *string, int len)
1415 {
1416   char path[PATH_MAX + 1];
1417   struct stat statbuf;
1418
1419   if (string == NULL ||
1420       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1421     return unknown;
1422
1423   if (S_ISREG (statbuf.st_mode) ||
1424       S_ISBLK (statbuf.st_mode) ||
1425       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1426     return yes;
1427
1428   if (S_ISDIR (statbuf.st_mode))
1429     return no;
1430
1431   return unknown;
1432 }
1433
1434
1435 /* inquire_unformatted()-- Given a fortran string, determine if the file
1436  * is suitable for unformatted form.  Returns a C-style string. */
1437
1438 const char *
1439 inquire_unformatted (const char *string, int len)
1440 {
1441   return inquire_formatted (string, len);
1442 }
1443
1444
1445 /* inquire_access()-- Given a fortran string, determine if the file is
1446  * suitable for access. */
1447
1448 static const char *
1449 inquire_access (const char *string, int len, int mode)
1450 {
1451   char path[PATH_MAX + 1];
1452
1453   if (string == NULL || unpack_filename (path, string, len) ||
1454       access (path, mode) < 0)
1455     return no;
1456
1457   return yes;
1458 }
1459
1460
1461 /* inquire_read()-- Given a fortran string, determine if the file is
1462  * suitable for READ access. */
1463
1464 const char *
1465 inquire_read (const char *string, int len)
1466 {
1467   return inquire_access (string, len, R_OK);
1468 }
1469
1470
1471 /* inquire_write()-- Given a fortran string, determine if the file is
1472  * suitable for READ access. */
1473
1474 const char *
1475 inquire_write (const char *string, int len)
1476 {
1477   return inquire_access (string, len, W_OK);
1478 }
1479
1480
1481 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1482  * suitable for read and write access. */
1483
1484 const char *
1485 inquire_readwrite (const char *string, int len)
1486 {
1487   return inquire_access (string, len, R_OK | W_OK);
1488 }
1489
1490
1491 /* file_length()-- Return the file length in bytes, -1 if unknown */
1492
1493 gfc_offset
1494 file_length (stream * s)
1495 {
1496   return ((unix_stream *) s)->file_length;
1497 }
1498
1499
1500 /* file_position()-- Return the current position of the file */
1501
1502 gfc_offset
1503 file_position (stream * s)
1504 {
1505   return ((unix_stream *) s)->logical_offset;
1506 }
1507
1508
1509 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1510  * it is not */
1511
1512 int
1513 is_seekable (stream * s)
1514 {
1515   /* by convention, if file_length == -1, the file is not seekable
1516      note that a mmapped file is always seekable, an fd_ file may
1517      or may not be. */
1518   return ((unix_stream *) s)->file_length!=-1;
1519 }
1520
1521 try
1522 flush (stream *s)
1523 {
1524   return fd_flush( (unix_stream *) s);
1525 }
1526
1527
1528 /* How files are stored:  This is an operating-system specific issue,
1529    and therefore belongs here.  There are three cases to consider.
1530
1531    Direct Access:
1532       Records are written as block of bytes corresponding to the record
1533       length of the file.  This goes for both formatted and unformatted
1534       records.  Positioning is done explicitly for each data transfer,
1535       so positioning is not much of an issue.
1536
1537    Sequential Formatted:
1538       Records are separated by newline characters.  The newline character
1539       is prohibited from appearing in a string.  If it does, this will be
1540       messed up on the next read.  End of file is also the end of a record.
1541
1542    Sequential Unformatted:
1543       In this case, we are merely copying bytes to and from main storage,
1544       yet we need to keep track of varying record lengths.  We adopt
1545       the solution used by f2c.  Each record contains a pair of length
1546       markers:
1547
1548         Length of record n in bytes
1549         Data of record n
1550         Length of record n in bytes
1551
1552         Length of record n+1 in bytes
1553         Data of record n+1
1554         Length of record n+1 in bytes
1555
1556      The length is stored at the end of a record to allow backspacing to the
1557      previous record.  Between data transfer statements, the file pointer
1558      is left pointing to the first length of the current record.
1559
1560      ENDFILE records are never explicitly stored.
1561
1562 */