libgfortran/io/unix.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
   2    2011, 2012
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5    F2003 I/O support contributed by Jerry DeLisle
   6
   7 This file is part of the GNU Fortran runtime library (libgfortran).
   8
   9 Libgfortran is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 3, or (at your option)
  12 any later version.
  13
  14 Libgfortran is distributed in the hope that it will be useful,
  15 but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 GNU General Public License for more details.
  18
  19 Under Section 7 of GPL version 3, you are granted additional
  20 permissions described in the GCC Runtime Library Exception, version
  21 3.1, as published by the Free Software Foundation.
  22
  23 You should have received a copy of the GNU General Public License and
  24 a copy of the GCC Runtime Library Exception along with this program;
  25 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  26 <http://www.gnu.org/licenses/>.  */
  27
  28 /* Unix stream I/O module */
  29
  30 #include "io.h"
  31 #include "unix.h"
  32 #include <stdlib.h>
  33 #include <limits.h>
  34
  35 #include <unistd.h>
  36 #include <sys/stat.h>
  37 #include <fcntl.h>
  38 #include <assert.h>
  39
  40 #include <string.h>
  41 #include <errno.h>
  42
  43
  44 /* min macro that evaluates its arguments only once.  */
  45 #define min(a,b)                \
  46   ({ typeof (a) _a = (a);       \
  47     typeof (b) _b = (b);        \
  48     _a < _b ? _a : _b; })
  49
  50
  51 /* For mingw, we don't identify files by their inode number, but by a
  52    64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
  53 #ifdef __MINGW32__
  54
  55 #define WIN32_LEAN_AND_MEAN
  56 #include <windows.h>
  57
  58 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
  59 #undef lseek
  60 #define lseek _lseeki64
  61 #undef fstat
  62 #define fstat _fstati64
  63 #undef stat
  64 #define stat _stati64
  65 #endif
  66
  67 #ifndef HAVE_WORKING_STAT
  68 static uint64_t
  69 id_from_handle (HANDLE hFile)
  70 {
  71   BY_HANDLE_FILE_INFORMATION FileInformation;
  72
  73   if (hFile == INVALID_HANDLE_VALUE)
  74       return 0;
  75
  76   memset (&FileInformation, 0, sizeof(FileInformation));
  77   if (!GetFileInformationByHandle (hFile, &FileInformation))
  78     return 0;
  79
  80   return ((uint64_t) FileInformation.nFileIndexLow)
  81          | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
  82 }
  83
  84
  85 static uint64_t
  86 id_from_path (const char *path)
  87 {
  88   HANDLE hFile;
  89   uint64_t res;
  90
  91   if (!path || !*path || access (path, F_OK))
  92     return (uint64_t) -1;
  93
  94   hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
  95                       FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
  96                       NULL);
  97   res = id_from_handle (hFile);
  98   CloseHandle (hFile);
  99   return res;
 100 }
 101
 102
 103 static uint64_t
 104 id_from_fd (const int fd)
 105 {
 106   return id_from_handle ((HANDLE) _get_osfhandle (fd));
 107 }
 108
 109 #endif
 110 #endif
 111
 112 #ifndef PATH_MAX
 113 #define PATH_MAX 1024
 114 #endif
 115
 116 /* These flags aren't defined on all targets (mingw32), so provide them
 117    here.  */
 118 #ifndef S_IRGRP
 119 #define S_IRGRP 0
 120 #endif
 121
 122 #ifndef S_IWGRP
 123 #define S_IWGRP 0
 124 #endif
 125
 126 #ifndef S_IROTH
 127 #define S_IROTH 0
 128 #endif
 129
 130 #ifndef S_IWOTH
 131 #define S_IWOTH 0
 132 #endif
 133
 134
 135 #ifndef HAVE_ACCESS
 136
 137 #ifndef W_OK
 138 #define W_OK 2
 139 #endif
 140
 141 #ifndef R_OK
 142 #define R_OK 4
 143 #endif
 144
 145 #ifndef F_OK
 146 #define F_OK 0
 147 #endif
 148
 149 /* Fallback implementation of access() on systems that don't have it.
 150    Only modes R_OK, W_OK and F_OK are used in this file.  */
 151
 152 static int
 153 fallback_access (const char *path, int mode)
 154 {
 155   int fd;
 156
 157   if ((mode & R_OK) && (fd = open (path, O_RDONLY)) < 0)
 158     return -1;
 159   close (fd);
 160
 161   if ((mode & W_OK) && (fd = open (path, O_WRONLY)) < 0)
 162     return -1;
 163   close (fd);
 164
 165   if (mode == F_OK)
 166     {
 167       struct stat st;
 168       return stat (path, &st);
 169     }
 170
 171   return 0;
 172 }
 173
 174 #undef access
 175 #define access fallback_access
 176 #endif
 177
 178
 179 /* Unix and internal stream I/O module */
 180
 181 static const int BUFFER_SIZE = 8192;
 182
 183 typedef struct
 184 {
 185   stream st;
 186
 187   gfc_offset buffer_offset;     /* File offset of the start of the buffer */
 188   gfc_offset physical_offset;   /* Current physical file offset */
 189   gfc_offset logical_offset;    /* Current logical file offset */
 190   gfc_offset file_length;       /* Length of the file. */
 191
 192   char *buffer;                 /* Pointer to the buffer.  */
 193   int fd;                       /* The POSIX file descriptor.  */
 194
 195   int active;                   /* Length of valid bytes in the buffer */
 196
 197   int ndirty;                   /* Dirty bytes starting at buffer_offset */
 198
 199   /* Cached stat(2) values.  */
 200   dev_t st_dev;
 201   ino_t st_ino;
 202 }
 203 unix_stream;
 204
 205
 206 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
 207  * standard descriptors, returning a non-standard descriptor.  If the
 208  * user specifies that system errors should go to standard output,
 209  * then closes standard output, we don't want the system errors to a
 210  * file that has been given file descriptor 1 or 0.  We want to send
 211  * the error to the invalid descriptor. */
 212
 213 static int
 214 fix_fd (int fd)
 215 {
 216 #ifdef HAVE_DUP
 217   int input, output, error;
 218
 219   input = output = error = 0;
 220
 221   /* Unix allocates the lowest descriptors first, so a loop is not
 222      required, but this order is. */
 223   if (fd == STDIN_FILENO)
 224     {
 225       fd = dup (fd);
 226       input = 1;
 227     }
 228   if (fd == STDOUT_FILENO)
 229     {
 230       fd = dup (fd);
 231       output = 1;
 232     }
 233   if (fd == STDERR_FILENO)
 234     {
 235       fd = dup (fd);
 236       error = 1;
 237     }
 238
 239   if (input)
 240     close (STDIN_FILENO);
 241   if (output)
 242     close (STDOUT_FILENO);
 243   if (error)
 244     close (STDERR_FILENO);
 245 #endif
 246
 247   return fd;
 248 }
 249
 250
 251 /* If the stream corresponds to a preconnected unit, we flush the
 252    corresponding C stream.  This is bugware for mixed C-Fortran codes
 253    where the C code doesn't flush I/O before returning.  */
 254 void
 255 flush_if_preconnected (stream * s)
 256 {
 257   int fd;
 258
 259   fd = ((unix_stream *) s)->fd;
 260   if (fd == STDIN_FILENO)
 261     fflush (stdin);
 262   else if (fd == STDOUT_FILENO)
 263     fflush (stdout);
 264   else if (fd == STDERR_FILENO)
 265     fflush (stderr);
 266 }
 267
 268
 269 /********************************************************************
 270 Raw I/O functions (read, write, seek, tell, truncate, close).
 271
 272 These functions wrap the basic POSIX I/O syscalls. Any deviation in
 273 semantics is a bug, except the following: write restarts in case
 274 of being interrupted by a signal, and as the first argument the
 275 functions take the unix_stream struct rather than an integer file
 276 descriptor. Also, for POSIX read() and write() a nbyte argument larger
 277 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
 278 than size_t as for POSIX read/write.
 279 *********************************************************************/
 280
 281 static int
 282 raw_flush (unix_stream * s  __attribute__ ((unused)))
 283 {
 284   return 0;
 285 }
 286
 287 static ssize_t
 288 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
 289 {
 290   /* For read we can't do I/O in a loop like raw_write does, because
 291      that will break applications that wait for interactive I/O.  */
 292   return read (s->fd, buf, nbyte);
 293 }
 294
 295 static ssize_t
 296 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
 297 {
 298   ssize_t trans, bytes_left;
 299   char *buf_st;
 300
 301   bytes_left = nbyte;
 302   buf_st = (char *) buf;
 303
 304   /* We must write in a loop since some systems don't restart system
 305      calls in case of a signal.  */
 306   while (bytes_left > 0)
 307     {
 308       trans = write (s->fd, buf_st, bytes_left);
 309       if (trans < 0)
 310         {
 311           if (errno == EINTR)
 312             continue;
 313           else
 314             return trans;
 315         }
 316       buf_st += trans;
 317       bytes_left -= trans;
 318     }
 319
 320   return nbyte - bytes_left;
 321 }
 322
 323 static gfc_offset
 324 raw_seek (unix_stream * s, gfc_offset offset, int whence)
 325 {
 326   return lseek (s->fd, offset, whence);
 327 }
 328
 329 static gfc_offset
 330 raw_tell (unix_stream * s)
 331 {
 332   return lseek (s->fd, 0, SEEK_CUR);
 333 }
 334
 335 static gfc_offset
 336 raw_size (unix_stream * s)
 337 {
 338   struct stat statbuf;
 339   int ret = fstat (s->fd, &statbuf);
 340   if (ret == -1)
 341     return ret;
 342   return statbuf.st_size;
 343 }
 344
 345 static int
 346 raw_truncate (unix_stream * s, gfc_offset length)
 347 {
 348 #ifdef __MINGW32__
 349   HANDLE h;
 350   gfc_offset cur;
 351
 352   if (isatty (s->fd))
 353     {
 354       errno = EBADF;
 355       return -1;
 356     }
 357   h = (HANDLE) _get_osfhandle (s->fd);
 358   if (h == INVALID_HANDLE_VALUE)
 359     {
 360       errno = EBADF;
 361       return -1;
 362     }
 363   cur = lseek (s->fd, 0, SEEK_CUR);
 364   if (cur == -1)
 365     return -1;
 366   if (lseek (s->fd, length, SEEK_SET) == -1)
 367     goto error;
 368   if (!SetEndOfFile (h))
 369     {
 370       errno = EBADF;
 371       goto error;
 372     }
 373   if (lseek (s->fd, cur, SEEK_SET) == -1)
 374     return -1;
 375   return 0;
 376  error:
 377   lseek (s->fd, cur, SEEK_SET);
 378   return -1;
 379 #elif defined HAVE_FTRUNCATE
 380   return ftruncate (s->fd, length);
 381 #elif defined HAVE_CHSIZE
 382   return chsize (s->fd, length);
 383 #else
 384   runtime_error ("required ftruncate or chsize support not present");
 385   return -1;
 386 #endif
 387 }
 388
 389 static int
 390 raw_close (unix_stream * s)
 391 {
 392   int retval;
 393
 394   if (s->fd != STDOUT_FILENO
 395       && s->fd != STDERR_FILENO
 396       && s->fd != STDIN_FILENO)
 397     retval = close (s->fd);
 398   else
 399     retval = 0;
 400   free (s);
 401   return retval;
 402 }
 403
 404 static const struct stream_vtable raw_vtable = {
 405   .read = (void *) raw_read,
 406   .write = (void *) raw_write,
 407   .seek = (void *) raw_seek,
 408   .tell = (void *) raw_tell,
 409   .size = (void *) raw_size,
 410   .trunc = (void *) raw_truncate,
 411   .close = (void *) raw_close,
 412   .flush = (void *) raw_flush
 413 };
 414
 415 static int
 416 raw_init (unix_stream * s)
 417 {
 418   s->st.vptr = &raw_vtable;
 419
 420   s->buffer = NULL;
 421   return 0;
 422 }
 423
 424
 425 /*********************************************************************
 426 Buffered I/O functions. These functions have the same semantics as the
 427 raw I/O functions above, except that they are buffered in order to
 428 improve performance. The buffer must be flushed when switching from
 429 reading to writing and vice versa. Only supported for regular files.
 430 *********************************************************************/
 431
 432 static int
 433 buf_flush (unix_stream * s)
 434 {
 435   int writelen;
 436
 437   /* Flushing in read mode means discarding read bytes.  */
 438   s->active = 0;
 439
 440   if (s->ndirty == 0)
 441     return 0;
 442
 443   if (s->physical_offset != s->buffer_offset
 444       && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
 445     return -1;
 446
 447   writelen = raw_write (s, s->buffer, s->ndirty);
 448
 449   s->physical_offset = s->buffer_offset + writelen;
 450
 451   if (s->physical_offset > s->file_length)
 452       s->file_length = s->physical_offset;
 453
 454   s->ndirty -= writelen;
 455   if (s->ndirty != 0)
 456     return -1;
 457
 458   return 0;
 459 }
 460
 461 static ssize_t
 462 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
 463 {
 464   if (s->active == 0)
 465     s->buffer_offset = s->logical_offset;
 466
 467   /* Is the data we want in the buffer?  */
 468   if (s->logical_offset + nbyte <= s->buffer_offset + s->active
 469       && s->buffer_offset <= s->logical_offset)
 470     memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
 471   else
 472     {
 473       /* First copy the active bytes if applicable, then read the rest
 474          either directly or filling the buffer.  */
 475       char *p;
 476       int nread = 0;
 477       ssize_t to_read, did_read;
 478       gfc_offset new_logical;
 479
 480       p = (char *) buf;
 481       if (s->logical_offset >= s->buffer_offset
 482           && s->buffer_offset + s->active >= s->logical_offset)
 483         {
 484           nread = s->active - (s->logical_offset - s->buffer_offset);
 485           memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
 486                   nread);
 487           p += nread;
 488         }
 489       /* At this point we consider all bytes in the buffer discarded.  */
 490       to_read = nbyte - nread;
 491       new_logical = s->logical_offset + nread;
 492       if (s->physical_offset != new_logical
 493           && lseek (s->fd, new_logical, SEEK_SET) < 0)
 494         return -1;
 495       s->buffer_offset = s->physical_offset = new_logical;
 496       if (to_read <= BUFFER_SIZE/2)
 497         {
 498           did_read = raw_read (s, s->buffer, BUFFER_SIZE);
 499           s->physical_offset += did_read;
 500           s->active = did_read;
 501           did_read = (did_read > to_read) ? to_read : did_read;
 502           memcpy (p, s->buffer, did_read);
 503         }
 504       else
 505         {
 506           did_read = raw_read (s, p, to_read);
 507           s->physical_offset += did_read;
 508           s->active = 0;
 509         }
 510       nbyte = did_read + nread;
 511     }
 512   s->logical_offset += nbyte;
 513   return nbyte;
 514 }
 515
 516 static ssize_t
 517 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
 518 {
 519   if (s->ndirty == 0)
 520     s->buffer_offset = s->logical_offset;
 521
 522   /* Does the data fit into the buffer?  As a special case, if the
 523      buffer is empty and the request is bigger than BUFFER_SIZE/2,
 524      write directly. This avoids the case where the buffer would have
 525      to be flushed at every write.  */
 526   if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
 527       && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
 528       && s->buffer_offset <= s->logical_offset
 529       && s->buffer_offset + s->ndirty >= s->logical_offset)
 530     {
 531       memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
 532       int nd = (s->logical_offset - s->buffer_offset) + nbyte;
 533       if (nd > s->ndirty)
 534         s->ndirty = nd;
 535     }
 536   else
 537     {
 538       /* Flush, and either fill the buffer with the new data, or if
 539          the request is bigger than the buffer size, write directly
 540          bypassing the buffer.  */
 541       buf_flush (s);
 542       if (nbyte <= BUFFER_SIZE/2)
 543         {
 544           memcpy (s->buffer, buf, nbyte);
 545           s->buffer_offset = s->logical_offset;
 546           s->ndirty += nbyte;
 547         }
 548       else
 549         {
 550           if (s->physical_offset != s->logical_offset)
 551             {
 552               if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
 553                 return -1;
 554               s->physical_offset = s->logical_offset;
 555             }
 556
 557           nbyte = raw_write (s, buf, nbyte);
 558           s->physical_offset += nbyte;
 559         }
 560     }
 561   s->logical_offset += nbyte;
 562   if (s->logical_offset > s->file_length)
 563     s->file_length = s->logical_offset;
 564   return nbyte;
 565 }
 566
 567 static gfc_offset
 568 buf_seek (unix_stream * s, gfc_offset offset, int whence)
 569 {
 570   switch (whence)
 571     {
 572     case SEEK_SET:
 573       break;
 574     case SEEK_CUR:
 575       offset += s->logical_offset;
 576       break;
 577     case SEEK_END:
 578       offset += s->file_length;
 579       break;
 580     default:
 581       return -1;
 582     }
 583   if (offset < 0)
 584     {
 585       errno = EINVAL;
 586       return -1;
 587     }
 588   s->logical_offset = offset;
 589   return offset;
 590 }
 591
 592 static gfc_offset
 593 buf_tell (unix_stream * s)
 594 {
 595   return buf_seek (s, 0, SEEK_CUR);
 596 }
 597
 598 static gfc_offset
 599 buf_size (unix_stream * s)
 600 {
 601   return s->file_length;
 602 }
 603
 604 static int
 605 buf_truncate (unix_stream * s, gfc_offset length)
 606 {
 607   int r;
 608
 609   if (buf_flush (s) != 0)
 610     return -1;
 611   r = raw_truncate (s, length);
 612   if (r == 0)
 613     s->file_length = length;
 614   return r;
 615 }
 616
 617 static int
 618 buf_close (unix_stream * s)
 619 {
 620   if (buf_flush (s) != 0)
 621     return -1;
 622   free (s->buffer);
 623   return raw_close (s);
 624 }
 625
 626 static const struct stream_vtable buf_vtable = {
 627   .read = (void *) buf_read,
 628   .write = (void *) buf_write,
 629   .seek = (void *) buf_seek,
 630   .tell = (void *) buf_tell,
 631   .size = (void *) buf_size,
 632   .trunc = (void *) buf_truncate,
 633   .close = (void *) buf_close,
 634   .flush = (void *) buf_flush
 635 };
 636
 637 static int
 638 buf_init (unix_stream * s)
 639 {
 640   s->st.vptr = &buf_vtable;
 641
 642   s->buffer = xmalloc (BUFFER_SIZE);
 643   return 0;
 644 }
 645
 646
 647 /*********************************************************************
 648   memory stream functions - These are used for internal files
 649
 650   The idea here is that a single stream structure is created and all
 651   requests must be satisfied from it.  The location and size of the
 652   buffer is the character variable supplied to the READ or WRITE
 653   statement.
 654
 655 *********************************************************************/
 656
 657 char *
 658 mem_alloc_r (stream * strm, int * len)
 659 {
 660   unix_stream * s = (unix_stream *) strm;
 661   gfc_offset n;
 662   gfc_offset where = s->logical_offset;
 663
 664   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 665     return NULL;
 666
 667   n = s->buffer_offset + s->active - where;
 668   if (*len > n)
 669     *len = n;
 670
 671   s->logical_offset = where + *len;
 672
 673   return s->buffer + (where - s->buffer_offset);
 674 }
 675
 676
 677 char *
 678 mem_alloc_r4 (stream * strm, int * len)
 679 {
 680   unix_stream * s = (unix_stream *) strm;
 681   gfc_offset n;
 682   gfc_offset where = s->logical_offset;
 683
 684   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 685     return NULL;
 686
 687   n = s->buffer_offset + s->active - where;
 688   if (*len > n)
 689     *len = n;
 690
 691   s->logical_offset = where + *len;
 692
 693   return s->buffer + (where - s->buffer_offset) * 4;
 694 }
 695
 696
 697 char *
 698 mem_alloc_w (stream * strm, int * len)
 699 {
 700   unix_stream * s = (unix_stream *) strm;
 701   gfc_offset m;
 702   gfc_offset where = s->logical_offset;
 703
 704   m = where + *len;
 705
 706   if (where < s->buffer_offset)
 707     return NULL;
 708
 709   if (m > s->file_length)
 710     return NULL;
 711
 712   s->logical_offset = m;
 713
 714   return s->buffer + (where - s->buffer_offset);
 715 }
 716
 717
 718 gfc_char4_t *
 719 mem_alloc_w4 (stream * strm, int * len)
 720 {
 721   unix_stream * s = (unix_stream *) strm;
 722   gfc_offset m;
 723   gfc_offset where = s->logical_offset;
 724   gfc_char4_t *result = (gfc_char4_t *) s->buffer;
 725
 726   m = where + *len;
 727
 728   if (where < s->buffer_offset)
 729     return NULL;
 730
 731   if (m > s->file_length)
 732     return NULL;
 733
 734   s->logical_offset = m;
 735   return &result[where - s->buffer_offset];
 736 }
 737
 738
 739 /* Stream read function for character(kind=1) internal units.  */
 740
 741 static ssize_t
 742 mem_read (stream * s, void * buf, ssize_t nbytes)
 743 {
 744   void *p;
 745   int nb = nbytes;
 746
 747   p = mem_alloc_r (s, &nb);
 748   if (p)
 749     {
 750       memcpy (buf, p, nb);
 751       return (ssize_t) nb;
 752     }
 753   else
 754     return 0;
 755 }
 756
 757
 758 /* Stream read function for chracter(kind=4) internal units.  */
 759
 760 static ssize_t
 761 mem_read4 (stream * s, void * buf, ssize_t nbytes)
 762 {
 763   void *p;
 764   int nb = nbytes;
 765
 766   p = mem_alloc_r (s, &nb);
 767   if (p)
 768     {
 769       memcpy (buf, p, nb);
 770       return (ssize_t) nb;
 771     }
 772   else
 773     return 0;
 774 }
 775
 776
 777 /* Stream write function for character(kind=1) internal units.  */
 778
 779 static ssize_t
 780 mem_write (stream * s, const void * buf, ssize_t nbytes)
 781 {
 782   void *p;
 783   int nb = nbytes;
 784
 785   p = mem_alloc_w (s, &nb);
 786   if (p)
 787     {
 788       memcpy (p, buf, nb);
 789       return (ssize_t) nb;
 790     }
 791   else
 792     return 0;
 793 }
 794
 795
 796 /* Stream write function for character(kind=4) internal units.  */
 797
 798 static ssize_t
 799 mem_write4 (stream * s, const void * buf, ssize_t nwords)
 800 {
 801   gfc_char4_t *p;
 802   int nw = nwords;
 803
 804   p = mem_alloc_w4 (s, &nw);
 805   if (p)
 806     {
 807       while (nw--)
 808         *p++ = (gfc_char4_t) *((char *) buf);
 809       return nwords;
 810     }
 811   else
 812     return 0;
 813 }
 814
 815
 816 static gfc_offset
 817 mem_seek (stream * strm, gfc_offset offset, int whence)
 818 {
 819   unix_stream * s = (unix_stream *) strm;
 820   switch (whence)
 821     {
 822     case SEEK_SET:
 823       break;
 824     case SEEK_CUR:
 825       offset += s->logical_offset;
 826       break;
 827     case SEEK_END:
 828       offset += s->file_length;
 829       break;
 830     default:
 831       return -1;
 832     }
 833
 834   /* Note that for internal array I/O it's actually possible to have a
 835      negative offset, so don't check for that.  */
 836   if (offset > s->file_length)
 837     {
 838       errno = EINVAL;
 839       return -1;
 840     }
 841
 842   s->logical_offset = offset;
 843
 844   /* Returning < 0 is the error indicator for sseek(), so return 0 if
 845      offset is negative.  Thus if the return value is 0, the caller
 846      has to use stell() to get the real value of logical_offset.  */
 847   if (offset >= 0)
 848     return offset;
 849   return 0;
 850 }
 851
 852
 853 static gfc_offset
 854 mem_tell (stream * s)
 855 {
 856   return ((unix_stream *)s)->logical_offset;
 857 }
 858
 859
 860 static int
 861 mem_truncate (unix_stream * s __attribute__ ((unused)),
 862               gfc_offset length __attribute__ ((unused)))
 863 {
 864   return 0;
 865 }
 866
 867
 868 static int
 869 mem_flush (unix_stream * s __attribute__ ((unused)))
 870 {
 871   return 0;
 872 }
 873
 874
 875 static int
 876 mem_close (unix_stream * s)
 877 {
 878   free (s);
 879
 880   return 0;
 881 }
 882
 883 static const struct stream_vtable mem_vtable = {
 884   .read = (void *) mem_read,
 885   .write = (void *) mem_write,
 886   .seek = (void *) mem_seek,
 887   .tell = (void *) mem_tell,
 888   /* buf_size is not a typo, we just reuse an identical
 889      implementation.  */
 890   .size = (void *) buf_size,
 891   .trunc = (void *) mem_truncate,
 892   .close = (void *) mem_close,
 893   .flush = (void *) mem_flush
 894 };
 895
 896 static const struct stream_vtable mem4_vtable = {
 897   .read = (void *) mem_read4,
 898   .write = (void *) mem_write4,
 899   .seek = (void *) mem_seek,
 900   .tell = (void *) mem_tell,
 901   /* buf_size is not a typo, we just reuse an identical
 902      implementation.  */
 903   .size = (void *) buf_size,
 904   .trunc = (void *) mem_truncate,
 905   .close = (void *) mem_close,
 906   .flush = (void *) mem_flush
 907 };
 908
 909 /*********************************************************************
 910   Public functions -- A reimplementation of this module needs to
 911   define functional equivalents of the following.
 912 *********************************************************************/
 913
 914 /* open_internal()-- Returns a stream structure from a character(kind=1)
 915    internal file */
 916
 917 stream *
 918 open_internal (char *base, int length, gfc_offset offset)
 919 {
 920   unix_stream *s;
 921
 922   s = xcalloc (1, sizeof (unix_stream));
 923
 924   s->buffer = base;
 925   s->buffer_offset = offset;
 926
 927   s->active = s->file_length = length;
 928
 929   s->st.vptr = &mem_vtable;
 930
 931   return (stream *) s;
 932 }
 933
 934 /* open_internal4()-- Returns a stream structure from a character(kind=4)
 935    internal file */
 936
 937 stream *
 938 open_internal4 (char *base, int length, gfc_offset offset)
 939 {
 940   unix_stream *s;
 941
 942   s = xcalloc (1, sizeof (unix_stream));
 943
 944   s->buffer = base;
 945   s->buffer_offset = offset;
 946
 947   s->active = s->file_length = length;
 948
 949   s->st.vptr = &mem4_vtable;
 950
 951   return (stream *) s;
 952 }
 953
 954
 955 /* fd_to_stream()-- Given an open file descriptor, build a stream
 956  * around it. */
 957
 958 static stream *
 959 fd_to_stream (int fd)
 960 {
 961   struct stat statbuf;
 962   unix_stream *s;
 963
 964   s = xcalloc (1, sizeof (unix_stream));
 965
 966   s->fd = fd;
 967
 968   /* Get the current length of the file. */
 969
 970   fstat (fd, &statbuf);
 971
 972   s->st_dev = statbuf.st_dev;
 973   s->st_ino = statbuf.st_ino;
 974   s->file_length = statbuf.st_size;
 975
 976   /* Only use buffered IO for regular files.  */
 977   if (S_ISREG (statbuf.st_mode)
 978       && !options.all_unbuffered
 979       && !(options.unbuffered_preconnected &&
 980            (s->fd == STDIN_FILENO
 981             || s->fd == STDOUT_FILENO
 982             || s->fd == STDERR_FILENO)))
 983     buf_init (s);
 984   else
 985     raw_init (s);
 986
 987   return (stream *) s;
 988 }
 989
 990
 991 /* Given the Fortran unit number, convert it to a C file descriptor.  */
 992
 993 int
 994 unit_to_fd (int unit)
 995 {
 996   gfc_unit *us;
 997   int fd;
 998
 999   us = find_unit (unit);
1000   if (us == NULL)
1001     return -1;
1002
1003   fd = ((unix_stream *) us->s)->fd;
1004   unlock_unit (us);
1005   return fd;
1006 }
1007
1008
1009 /* unpack_filename()-- Given a fortran string and a pointer to a
1010  * buffer that is PATH_MAX characters, convert the fortran string to a
1011  * C string in the buffer.  Returns nonzero if this is not possible.  */
1012
1013 int
1014 unpack_filename (char *cstring, const char *fstring, int len)
1015 {
1016   if (fstring == NULL)
1017     return EFAULT;
1018   len = fstrlen (fstring, len);
1019   if (len >= PATH_MAX)
1020     return ENAMETOOLONG;
1021
1022   memmove (cstring, fstring, len);
1023   cstring[len] = '\0';
1024
1025   return 0;
1026 }
1027
1028
1029 /* tempfile()-- Generate a temporary filename for a scratch file and
1030  * open it.  mkstemp() opens the file for reading and writing, but the
1031  * library mode prevents anything that is not allowed.  The descriptor
1032  * is returned, which is -1 on error.  The template is pointed to by
1033  * opp->file, which is copied into the unit structure
1034  * and freed later. */
1035
1036 static int
1037 tempfile (st_parameter_open *opp)
1038 {
1039   const char *tempdir;
1040   char *template;
1041   const char *slash = "/";
1042   int fd;
1043   size_t tempdirlen;
1044
1045 #ifndef HAVE_MKSTEMP
1046   int count;
1047   size_t slashlen;
1048 #endif
1049
1050   tempdir = getenv ("GFORTRAN_TMPDIR");
1051 #ifdef __MINGW32__
1052   if (tempdir == NULL)
1053     {
1054       char buffer[MAX_PATH + 1];
1055       DWORD ret;
1056       ret = GetTempPath (MAX_PATH, buffer);
1057       /* If we are not able to get a temp-directory, we use
1058          current directory.  */
1059       if (ret > MAX_PATH || !ret)
1060         buffer[0] = 0;
1061       else
1062         buffer[ret] = 0;
1063       tempdir = strdup (buffer);
1064     }
1065 #else
1066   if (tempdir == NULL)
1067     tempdir = getenv ("TMP");
1068   if (tempdir == NULL)
1069     tempdir = getenv ("TEMP");
1070   if (tempdir == NULL)
1071     tempdir = DEFAULT_TEMPDIR;
1072 #endif
1073
1074   /* Check for special case that tempdir contains slash
1075      or backslash at end.  */
1076   tempdirlen = strlen (tempdir);
1077   if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1078 #ifdef __MINGW32__
1079       || tempdir[tempdirlen - 1] == '\\'
1080 #endif
1081      )
1082     slash = "";
1083
1084   // Take care that the template is longer in the mktemp() branch.
1085   template = xmalloc (tempdirlen + 23);
1086
1087 #ifdef HAVE_MKSTEMP
1088   snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1089             tempdir, slash);
1090
1091   fd = mkstemp (template);
1092
1093 #else /* HAVE_MKSTEMP */
1094   fd = -1;
1095   count = 0;
1096   slashlen = strlen (slash);
1097   do
1098     {
1099       snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1100                 tempdir, slash);
1101       if (count > 0)
1102         {
1103           int c = count;
1104           template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1105           c /= 26;
1106           template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1107           c /= 26;
1108           template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1109           if (c >= 26)
1110             break;
1111         }
1112
1113       if (!mktemp (template))
1114       {
1115         errno = EEXIST;
1116         count++;
1117         continue;
1118       }
1119
1120 #if defined(HAVE_CRLF) && defined(O_BINARY)
1121       fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1122                  S_IRUSR | S_IWUSR);
1123 #else
1124       fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR);
1125 #endif
1126     }
1127   while (fd == -1 && errno == EEXIST);
1128 #endif /* HAVE_MKSTEMP */
1129
1130   opp->file = template;
1131   opp->file_len = strlen (template);    /* Don't include trailing nul */
1132
1133   return fd;
1134 }
1135
1136
1137 /* regular_file()-- Open a regular file.
1138  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1139  * unless an error occurs.
1140  * Returns the descriptor, which is less than zero on error. */
1141
1142 static int
1143 regular_file (st_parameter_open *opp, unit_flags *flags)
1144 {
1145   char path[min(PATH_MAX, opp->file_len + 1)];
1146   int mode;
1147   int rwflag;
1148   int crflag;
1149   int fd;
1150   int err;
1151
1152   err = unpack_filename (path, opp->file, opp->file_len);
1153   if (err)
1154     {
1155       errno = err;              /* Fake an OS error */
1156       return -1;
1157     }
1158
1159 #ifdef __CYGWIN__
1160   if (opp->file_len == 7)
1161     {
1162       if (strncmp (path, "CONOUT$", 7) == 0
1163           || strncmp (path, "CONERR$", 7) == 0)
1164         {
1165           fd = open ("/dev/conout", O_WRONLY);
1166           flags->action = ACTION_WRITE;
1167           return fd;
1168         }
1169     }
1170
1171   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1172     {
1173       fd = open ("/dev/conin", O_RDONLY);
1174       flags->action = ACTION_READ;
1175       return fd;
1176     }
1177 #endif
1178
1179
1180 #ifdef __MINGW32__
1181   if (opp->file_len == 7)
1182     {
1183       if (strncmp (path, "CONOUT$", 7) == 0
1184           || strncmp (path, "CONERR$", 7) == 0)
1185         {
1186           fd = open ("CONOUT$", O_WRONLY);
1187           flags->action = ACTION_WRITE;
1188           return fd;
1189         }
1190     }
1191
1192   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1193     {
1194       fd = open ("CONIN$", O_RDONLY);
1195       flags->action = ACTION_READ;
1196       return fd;
1197     }
1198 #endif
1199
1200   rwflag = 0;
1201
1202   switch (flags->action)
1203     {
1204     case ACTION_READ:
1205       rwflag = O_RDONLY;
1206       break;
1207
1208     case ACTION_WRITE:
1209       rwflag = O_WRONLY;
1210       break;
1211
1212     case ACTION_READWRITE:
1213     case ACTION_UNSPECIFIED:
1214       rwflag = O_RDWR;
1215       break;
1216
1217     default:
1218       internal_error (&opp->common, "regular_file(): Bad action");
1219     }
1220
1221   switch (flags->status)
1222     {
1223     case STATUS_NEW:
1224       crflag = O_CREAT | O_EXCL;
1225       break;
1226
1227     case STATUS_OLD:            /* open will fail if the file does not exist*/
1228       crflag = 0;
1229       break;
1230
1231     case STATUS_UNKNOWN:
1232     case STATUS_SCRATCH:
1233       crflag = O_CREAT;
1234       break;
1235
1236     case STATUS_REPLACE:
1237       crflag = O_CREAT | O_TRUNC;
1238       break;
1239
1240     default:
1241       internal_error (&opp->common, "regular_file(): Bad status");
1242     }
1243
1244   /* rwflag |= O_LARGEFILE; */
1245
1246 #if defined(HAVE_CRLF) && defined(O_BINARY)
1247   crflag |= O_BINARY;
1248 #endif
1249
1250   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1251   fd = open (path, rwflag | crflag, mode);
1252   if (flags->action != ACTION_UNSPECIFIED)
1253     return fd;
1254
1255   if (fd >= 0)
1256     {
1257       flags->action = ACTION_READWRITE;
1258       return fd;
1259     }
1260   if (errno != EACCES && errno != EROFS)
1261      return fd;
1262
1263   /* retry for read-only access */
1264   rwflag = O_RDONLY;
1265   fd = open (path, rwflag | crflag, mode);
1266   if (fd >=0)
1267     {
1268       flags->action = ACTION_READ;
1269       return fd;                /* success */
1270     }
1271
1272   if (errno != EACCES)
1273     return fd;                  /* failure */
1274
1275   /* retry for write-only access */
1276   rwflag = O_WRONLY;
1277   fd = open (path, rwflag | crflag, mode);
1278   if (fd >=0)
1279     {
1280       flags->action = ACTION_WRITE;
1281       return fd;                /* success */
1282     }
1283   return fd;                    /* failure */
1284 }
1285
1286
1287 /* open_external()-- Open an external file, unix specific version.
1288  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1289  * Returns NULL on operating system error. */
1290
1291 stream *
1292 open_external (st_parameter_open *opp, unit_flags *flags)
1293 {
1294   int fd;
1295
1296   if (flags->status == STATUS_SCRATCH)
1297     {
1298       fd = tempfile (opp);
1299       if (flags->action == ACTION_UNSPECIFIED)
1300         flags->action = ACTION_READWRITE;
1301
1302 #if HAVE_UNLINK_OPEN_FILE
1303       /* We can unlink scratch files now and it will go away when closed. */
1304       if (fd >= 0)
1305         unlink (opp->file);
1306 #endif
1307     }
1308   else
1309     {
1310       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1311        * if it succeeds */
1312       fd = regular_file (opp, flags);
1313     }
1314
1315   if (fd < 0)
1316     return NULL;
1317   fd = fix_fd (fd);
1318
1319   return fd_to_stream (fd);
1320 }
1321
1322
1323 /* input_stream()-- Return a stream pointer to the default input stream.
1324  * Called on initialization. */
1325
1326 stream *
1327 input_stream (void)
1328 {
1329   return fd_to_stream (STDIN_FILENO);
1330 }
1331
1332
1333 /* output_stream()-- Return a stream pointer to the default output stream.
1334  * Called on initialization. */
1335
1336 stream *
1337 output_stream (void)
1338 {
1339   stream * s;
1340
1341 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1342   setmode (STDOUT_FILENO, O_BINARY);
1343 #endif
1344
1345   s = fd_to_stream (STDOUT_FILENO);
1346   return s;
1347 }
1348
1349
1350 /* error_stream()-- Return a stream pointer to the default error stream.
1351  * Called on initialization. */
1352
1353 stream *
1354 error_stream (void)
1355 {
1356   stream * s;
1357
1358 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1359   setmode (STDERR_FILENO, O_BINARY);
1360 #endif
1361
1362   s = fd_to_stream (STDERR_FILENO);
1363   return s;
1364 }
1365
1366
1367 /* compare_file_filename()-- Given an open stream and a fortran string
1368  * that is a filename, figure out if the file is the same as the
1369  * filename. */
1370
1371 int
1372 compare_file_filename (gfc_unit *u, const char *name, int len)
1373 {
1374   char path[min(PATH_MAX, len + 1)];
1375   struct stat st;
1376 #ifdef HAVE_WORKING_STAT
1377   unix_stream *s;
1378 #else
1379 # ifdef __MINGW32__
1380   uint64_t id1, id2;
1381 # endif
1382 #endif
1383
1384   if (unpack_filename (path, name, len))
1385     return 0;                   /* Can't be the same */
1386
1387   /* If the filename doesn't exist, then there is no match with the
1388    * existing file. */
1389
1390   if (stat (path, &st) < 0)
1391     return 0;
1392
1393 #ifdef HAVE_WORKING_STAT
1394   s = (unix_stream *) (u->s);
1395   return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1396 #else
1397
1398 # ifdef __MINGW32__
1399   /* We try to match files by a unique ID.  On some filesystems (network
1400      fs and FAT), we can't generate this unique ID, and will simply compare
1401      filenames.  */
1402   id1 = id_from_path (path);
1403   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1404   if (id1 || id2)
1405     return (id1 == id2);
1406 # endif
1407
1408   if (len != u->file_len)
1409     return 0;
1410   return (memcmp(path, u->file, len) == 0);
1411 #endif
1412 }
1413
1414
1415 #ifdef HAVE_WORKING_STAT
1416 # define FIND_FILE0_DECL struct stat *st
1417 # define FIND_FILE0_ARGS st
1418 #else
1419 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1420 # define FIND_FILE0_ARGS id, file, file_len
1421 #endif
1422
1423 /* find_file0()-- Recursive work function for find_file() */
1424
1425 static gfc_unit *
1426 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1427 {
1428   gfc_unit *v;
1429 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1430   uint64_t id1;
1431 #endif
1432
1433   if (u == NULL)
1434     return NULL;
1435
1436 #ifdef HAVE_WORKING_STAT
1437   if (u->s != NULL)
1438     {
1439       unix_stream *s = (unix_stream *) (u->s);
1440       if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1441         return u;
1442     }
1443 #else
1444 # ifdef __MINGW32__
1445   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1446     {
1447       if (id == id1)
1448         return u;
1449     }
1450   else
1451 # endif
1452     if (compare_string (u->file_len, u->file, file_len, file) == 0)
1453       return u;
1454 #endif
1455
1456   v = find_file0 (u->left, FIND_FILE0_ARGS);
1457   if (v != NULL)
1458     return v;
1459
1460   v = find_file0 (u->right, FIND_FILE0_ARGS);
1461   if (v != NULL)
1462     return v;
1463
1464   return NULL;
1465 }
1466
1467
1468 /* find_file()-- Take the current filename and see if there is a unit
1469  * that has the file already open.  Returns a pointer to the unit if so. */
1470
1471 gfc_unit *
1472 find_file (const char *file, gfc_charlen_type file_len)
1473 {
1474   char path[min(PATH_MAX, file_len + 1)];
1475   struct stat st[1];
1476   gfc_unit *u;
1477 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1478   uint64_t id = 0ULL;
1479 #endif
1480
1481   if (unpack_filename (path, file, file_len))
1482     return NULL;
1483
1484   if (stat (path, &st[0]) < 0)
1485     return NULL;
1486
1487 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1488   id = id_from_path (path);
1489 #endif
1490
1491   __gthread_mutex_lock (&unit_lock);
1492 retry:
1493   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1494   if (u != NULL)
1495     {
1496       /* Fast path.  */
1497       if (! __gthread_mutex_trylock (&u->lock))
1498         {
1499           /* assert (u->closed == 0); */
1500           __gthread_mutex_unlock (&unit_lock);
1501           return u;
1502         }
1503
1504       inc_waiting_locked (u);
1505     }
1506   __gthread_mutex_unlock (&unit_lock);
1507   if (u != NULL)
1508     {
1509       __gthread_mutex_lock (&u->lock);
1510       if (u->closed)
1511         {
1512           __gthread_mutex_lock (&unit_lock);
1513           __gthread_mutex_unlock (&u->lock);
1514           if (predec_waiting_locked (u) == 0)
1515             free (u);
1516           goto retry;
1517         }
1518
1519       dec_waiting_unlocked (u);
1520     }
1521   return u;
1522 }
1523
1524 static gfc_unit *
1525 flush_all_units_1 (gfc_unit *u, int min_unit)
1526 {
1527   while (u != NULL)
1528     {
1529       if (u->unit_number > min_unit)
1530         {
1531           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1532           if (r != NULL)
1533             return r;
1534         }
1535       if (u->unit_number >= min_unit)
1536         {
1537           if (__gthread_mutex_trylock (&u->lock))
1538             return u;
1539           if (u->s)
1540             sflush (u->s);
1541           __gthread_mutex_unlock (&u->lock);
1542         }
1543       u = u->right;
1544     }
1545   return NULL;
1546 }
1547
1548 void
1549 flush_all_units (void)
1550 {
1551   gfc_unit *u;
1552   int min_unit = 0;
1553
1554   __gthread_mutex_lock (&unit_lock);
1555   do
1556     {
1557       u = flush_all_units_1 (unit_root, min_unit);
1558       if (u != NULL)
1559         inc_waiting_locked (u);
1560       __gthread_mutex_unlock (&unit_lock);
1561       if (u == NULL)
1562         return;
1563
1564       __gthread_mutex_lock (&u->lock);
1565
1566       min_unit = u->unit_number + 1;
1567
1568       if (u->closed == 0)
1569         {
1570           sflush (u->s);
1571           __gthread_mutex_lock (&unit_lock);
1572           __gthread_mutex_unlock (&u->lock);
1573           (void) predec_waiting_locked (u);
1574         }
1575       else
1576         {
1577           __gthread_mutex_lock (&unit_lock);
1578           __gthread_mutex_unlock (&u->lock);
1579           if (predec_waiting_locked (u) == 0)
1580             free (u);
1581         }
1582     }
1583   while (1);
1584 }
1585
1586
1587 /* delete_file()-- Given a unit structure, delete the file associated
1588  * with the unit.  Returns nonzero if something went wrong. */
1589
1590 int
1591 delete_file (gfc_unit * u)
1592 {
1593   char path[min(PATH_MAX, u->file_len + 1)];
1594   int err = unpack_filename (path, u->file, u->file_len);
1595
1596   if (err)
1597     {                           /* Shouldn't be possible */
1598       errno = err;
1599       return 1;
1600     }
1601
1602   return unlink (path);
1603 }
1604
1605
1606 /* file_exists()-- Returns nonzero if the current filename exists on
1607  * the system */
1608
1609 int
1610 file_exists (const char *file, gfc_charlen_type file_len)
1611 {
1612   char path[min(PATH_MAX, file_len + 1)];
1613
1614   if (unpack_filename (path, file, file_len))
1615     return 0;
1616
1617   return !(access (path, F_OK));
1618 }
1619
1620
1621 /* file_size()-- Returns the size of the file.  */
1622
1623 GFC_IO_INT
1624 file_size (const char *file, gfc_charlen_type file_len)
1625 {
1626   char path[min(PATH_MAX, file_len + 1)];
1627   struct stat statbuf;
1628
1629   if (unpack_filename (path, file, file_len))
1630     return -1;
1631
1632   if (stat (path, &statbuf) < 0)
1633     return -1;
1634
1635   return (GFC_IO_INT) statbuf.st_size;
1636 }
1637
1638 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1639
1640 /* inquire_sequential()-- Given a fortran string, determine if the
1641  * file is suitable for sequential access.  Returns a C-style
1642  * string. */
1643
1644 const char *
1645 inquire_sequential (const char *string, int len)
1646 {
1647   char path[min(PATH_MAX, len + 1)];
1648   struct stat statbuf;
1649
1650   if (string == NULL ||
1651       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1652     return unknown;
1653
1654   if (S_ISREG (statbuf.st_mode) ||
1655       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1656     return unknown;
1657
1658   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1659     return no;
1660
1661   return unknown;
1662 }
1663
1664
1665 /* inquire_direct()-- Given a fortran string, determine if the file is
1666  * suitable for direct access.  Returns a C-style string. */
1667
1668 const char *
1669 inquire_direct (const char *string, int len)
1670 {
1671   char path[min(PATH_MAX, len + 1)];
1672   struct stat statbuf;
1673
1674   if (string == NULL ||
1675       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1676     return unknown;
1677
1678   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1679     return unknown;
1680
1681   if (S_ISDIR (statbuf.st_mode) ||
1682       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1683     return no;
1684
1685   return unknown;
1686 }
1687
1688
1689 /* inquire_formatted()-- Given a fortran string, determine if the file
1690  * is suitable for formatted form.  Returns a C-style string. */
1691
1692 const char *
1693 inquire_formatted (const char *string, int len)
1694 {
1695   char path[min(PATH_MAX, len + 1)];
1696   struct stat statbuf;
1697
1698   if (string == NULL ||
1699       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1700     return unknown;
1701
1702   if (S_ISREG (statbuf.st_mode) ||
1703       S_ISBLK (statbuf.st_mode) ||
1704       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1705     return unknown;
1706
1707   if (S_ISDIR (statbuf.st_mode))
1708     return no;
1709
1710   return unknown;
1711 }
1712
1713
1714 /* inquire_unformatted()-- Given a fortran string, determine if the file
1715  * is suitable for unformatted form.  Returns a C-style string. */
1716
1717 const char *
1718 inquire_unformatted (const char *string, int len)
1719 {
1720   return inquire_formatted (string, len);
1721 }
1722
1723
1724 /* inquire_access()-- Given a fortran string, determine if the file is
1725  * suitable for access. */
1726
1727 static const char *
1728 inquire_access (const char *string, int len, int mode)
1729 {
1730   char path[min(PATH_MAX, len + 1)];
1731
1732   if (string == NULL || unpack_filename (path, string, len) ||
1733       access (path, mode) < 0)
1734     return no;
1735
1736   return yes;
1737 }
1738
1739
1740 /* inquire_read()-- Given a fortran string, determine if the file is
1741  * suitable for READ access. */
1742
1743 const char *
1744 inquire_read (const char *string, int len)
1745 {
1746   return inquire_access (string, len, R_OK);
1747 }
1748
1749
1750 /* inquire_write()-- Given a fortran string, determine if the file is
1751  * suitable for READ access. */
1752
1753 const char *
1754 inquire_write (const char *string, int len)
1755 {
1756   return inquire_access (string, len, W_OK);
1757 }
1758
1759
1760 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1761  * suitable for read and write access. */
1762
1763 const char *
1764 inquire_readwrite (const char *string, int len)
1765 {
1766   return inquire_access (string, len, R_OK | W_OK);
1767 }
1768
1769
1770 int
1771 stream_isatty (stream *s)
1772 {
1773   return isatty (((unix_stream *) s)->fd);
1774 }
1775
1776 int
1777 stream_ttyname (stream *s  __attribute__ ((unused)),
1778                 char * buf  __attribute__ ((unused)),
1779                 size_t buflen  __attribute__ ((unused)))
1780 {
1781 #ifdef HAVE_TTYNAME_R
1782   return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1783 #elif defined HAVE_TTYNAME
1784   char *p;
1785   size_t plen;
1786   p = ttyname (((unix_stream *) s)->fd);
1787   if (!p)
1788     return errno;
1789   plen = strlen (p);
1790   if (buflen < plen)
1791     plen = buflen;
1792   memcpy (buf, p, plen);
1793   return 0;
1794 #else
1795   return ENOSYS;
1796 #endif
1797 }
1798
1799
1800
1801
1802 /* How files are stored:  This is an operating-system specific issue,
1803    and therefore belongs here.  There are three cases to consider.
1804
1805    Direct Access:
1806       Records are written as block of bytes corresponding to the record
1807       length of the file.  This goes for both formatted and unformatted
1808       records.  Positioning is done explicitly for each data transfer,
1809       so positioning is not much of an issue.
1810
1811    Sequential Formatted:
1812       Records are separated by newline characters.  The newline character
1813       is prohibited from appearing in a string.  If it does, this will be
1814       messed up on the next read.  End of file is also the end of a record.
1815
1816    Sequential Unformatted:
1817       In this case, we are merely copying bytes to and from main storage,
1818       yet we need to keep track of varying record lengths.  We adopt
1819       the solution used by f2c.  Each record contains a pair of length
1820       markers:
1821
1822         Length of record n in bytes
1823         Data of record n
1824         Length of record n in bytes
1825
1826         Length of record n+1 in bytes
1827         Data of record n+1
1828         Length of record n+1 in bytes
1829
1830      The length is stored at the end of a record to allow backspacing to the
1831      previous record.  Between data transfer statements, the file pointer
1832      is left pointing to the first length of the current record.
1833
1834      ENDFILE records are never explicitly stored.
1835
1836 */