libgfortran/io/unix.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
   2    2011
   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 = get_mem (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(kine=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 = get_mem (sizeof (unix_stream));
 923   memset (s, '\0', sizeof (unix_stream));
 924
 925   s->buffer = base;
 926   s->buffer_offset = offset;
 927
 928   s->logical_offset = 0;
 929   s->active = s->file_length = length;
 930
 931   s->st.vptr = &mem_vtable;
 932
 933   return (stream *) s;
 934 }
 935
 936 /* open_internal4()-- Returns a stream structure from a character(kind=4)
 937    internal file */
 938
 939 stream *
 940 open_internal4 (char *base, int length, gfc_offset offset)
 941 {
 942   unix_stream *s;
 943
 944   s = get_mem (sizeof (unix_stream));
 945   memset (s, '\0', sizeof (unix_stream));
 946
 947   s->buffer = base;
 948   s->buffer_offset = offset;
 949
 950   s->logical_offset = 0;
 951   s->active = s->file_length = length;
 952
 953   s->st.vptr = &mem4_vtable;
 954
 955   return (stream *) s;
 956 }
 957
 958
 959 /* fd_to_stream()-- Given an open file descriptor, build a stream
 960  * around it. */
 961
 962 static stream *
 963 fd_to_stream (int fd)
 964 {
 965   struct stat statbuf;
 966   unix_stream *s;
 967
 968   s = get_mem (sizeof (unix_stream));
 969   memset (s, '\0', sizeof (unix_stream));
 970
 971   s->fd = fd;
 972   s->buffer_offset = 0;
 973   s->physical_offset = 0;
 974   s->logical_offset = 0;
 975
 976   /* Get the current length of the file. */
 977
 978   fstat (fd, &statbuf);
 979
 980   s->st_dev = statbuf.st_dev;
 981   s->st_ino = statbuf.st_ino;
 982   s->file_length = statbuf.st_size;
 983
 984   /* Only use buffered IO for regular files.  */
 985   if (S_ISREG (statbuf.st_mode)
 986       && !options.all_unbuffered
 987       && !(options.unbuffered_preconnected &&
 988            (s->fd == STDIN_FILENO
 989             || s->fd == STDOUT_FILENO
 990             || s->fd == STDERR_FILENO)))
 991     buf_init (s);
 992   else
 993     raw_init (s);
 994
 995   return (stream *) s;
 996 }
 997
 998
 999 /* Given the Fortran unit number, convert it to a C file descriptor.  */
1000
1001 int
1002 unit_to_fd (int unit)
1003 {
1004   gfc_unit *us;
1005   int fd;
1006
1007   us = find_unit (unit);
1008   if (us == NULL)
1009     return -1;
1010
1011   fd = ((unix_stream *) us->s)->fd;
1012   unlock_unit (us);
1013   return fd;
1014 }
1015
1016
1017 /* unpack_filename()-- Given a fortran string and a pointer to a
1018  * buffer that is PATH_MAX characters, convert the fortran string to a
1019  * C string in the buffer.  Returns nonzero if this is not possible.  */
1020
1021 int
1022 unpack_filename (char *cstring, const char *fstring, int len)
1023 {
1024   if (fstring == NULL)
1025     return EFAULT;
1026   len = fstrlen (fstring, len);
1027   if (len >= PATH_MAX)
1028     return ENAMETOOLONG;
1029
1030   memmove (cstring, fstring, len);
1031   cstring[len] = '\0';
1032
1033   return 0;
1034 }
1035
1036
1037 /* tempfile()-- Generate a temporary filename for a scratch file and
1038  * open it.  mkstemp() opens the file for reading and writing, but the
1039  * library mode prevents anything that is not allowed.  The descriptor
1040  * is returned, which is -1 on error.  The template is pointed to by
1041  * opp->file, which is copied into the unit structure
1042  * and freed later. */
1043
1044 static int
1045 tempfile (st_parameter_open *opp)
1046 {
1047   const char *tempdir;
1048   char *template;
1049   const char *slash = "/";
1050   int fd;
1051   size_t tempdirlen;
1052
1053 #ifndef HAVE_MKSTEMP
1054   int count;
1055   size_t slashlen;
1056 #endif
1057
1058   tempdir = getenv ("GFORTRAN_TMPDIR");
1059 #ifdef __MINGW32__
1060   if (tempdir == NULL)
1061     {
1062       char buffer[MAX_PATH + 1];
1063       DWORD ret;
1064       ret = GetTempPath (MAX_PATH, buffer);
1065       /* If we are not able to get a temp-directory, we use
1066          current directory.  */
1067       if (ret > MAX_PATH || !ret)
1068         buffer[0] = 0;
1069       else
1070         buffer[ret] = 0;
1071       tempdir = strdup (buffer);
1072     }
1073 #else
1074   if (tempdir == NULL)
1075     tempdir = getenv ("TMP");
1076   if (tempdir == NULL)
1077     tempdir = getenv ("TEMP");
1078   if (tempdir == NULL)
1079     tempdir = DEFAULT_TEMPDIR;
1080 #endif
1081
1082   /* Check for special case that tempdir contains slash
1083      or backslash at end.  */
1084   tempdirlen = strlen (tempdir);
1085   if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1086 #ifdef __MINGW32__
1087       || tempdir[tempdirlen - 1] == '\\'
1088 #endif
1089      )
1090     slash = "";
1091
1092   // Take care that the template is longer in the mktemp() branch.
1093   template = get_mem (tempdirlen + 23);
1094
1095 #ifdef HAVE_MKSTEMP
1096   snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1097             tempdir, slash);
1098
1099   fd = mkstemp (template);
1100
1101 #else /* HAVE_MKSTEMP */
1102   fd = -1;
1103   count = 0;
1104   slashlen = strlen (slash);
1105   do
1106     {
1107       snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1108                 tempdir, slash);
1109       if (count > 0)
1110         {
1111           int c = count;
1112           template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1113           c /= 26;
1114           template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1115           c /= 26;
1116           template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1117           if (c >= 26)
1118             break;
1119         }
1120
1121       if (!mktemp (template))
1122       {
1123         errno = EEXIST;
1124         count++;
1125         continue;
1126       }
1127
1128 #if defined(HAVE_CRLF) && defined(O_BINARY)
1129       fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1130                  S_IRUSR | S_IWUSR);
1131 #else
1132       fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR);
1133 #endif
1134     }
1135   while (fd == -1 && errno == EEXIST);
1136 #endif /* HAVE_MKSTEMP */
1137
1138   opp->file = template;
1139   opp->file_len = strlen (template);    /* Don't include trailing nul */
1140
1141   return fd;
1142 }
1143
1144
1145 /* regular_file()-- Open a regular file.
1146  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1147  * unless an error occurs.
1148  * Returns the descriptor, which is less than zero on error. */
1149
1150 static int
1151 regular_file (st_parameter_open *opp, unit_flags *flags)
1152 {
1153   char path[min(PATH_MAX, opp->file_len + 1)];
1154   int mode;
1155   int rwflag;
1156   int crflag;
1157   int fd;
1158   int err;
1159
1160   err = unpack_filename (path, opp->file, opp->file_len);
1161   if (err)
1162     {
1163       errno = err;              /* Fake an OS error */
1164       return -1;
1165     }
1166
1167 #ifdef __CYGWIN__
1168   if (opp->file_len == 7)
1169     {
1170       if (strncmp (path, "CONOUT$", 7) == 0
1171           || strncmp (path, "CONERR$", 7) == 0)
1172         {
1173           fd = open ("/dev/conout", O_WRONLY);
1174           flags->action = ACTION_WRITE;
1175           return fd;
1176         }
1177     }
1178
1179   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1180     {
1181       fd = open ("/dev/conin", O_RDONLY);
1182       flags->action = ACTION_READ;
1183       return fd;
1184     }
1185 #endif
1186
1187
1188 #ifdef __MINGW32__
1189   if (opp->file_len == 7)
1190     {
1191       if (strncmp (path, "CONOUT$", 7) == 0
1192           || strncmp (path, "CONERR$", 7) == 0)
1193         {
1194           fd = open ("CONOUT$", O_WRONLY);
1195           flags->action = ACTION_WRITE;
1196           return fd;
1197         }
1198     }
1199
1200   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1201     {
1202       fd = open ("CONIN$", O_RDONLY);
1203       flags->action = ACTION_READ;
1204       return fd;
1205     }
1206 #endif
1207
1208   rwflag = 0;
1209
1210   switch (flags->action)
1211     {
1212     case ACTION_READ:
1213       rwflag = O_RDONLY;
1214       break;
1215
1216     case ACTION_WRITE:
1217       rwflag = O_WRONLY;
1218       break;
1219
1220     case ACTION_READWRITE:
1221     case ACTION_UNSPECIFIED:
1222       rwflag = O_RDWR;
1223       break;
1224
1225     default:
1226       internal_error (&opp->common, "regular_file(): Bad action");
1227     }
1228
1229   switch (flags->status)
1230     {
1231     case STATUS_NEW:
1232       crflag = O_CREAT | O_EXCL;
1233       break;
1234
1235     case STATUS_OLD:            /* open will fail if the file does not exist*/
1236       crflag = 0;
1237       break;
1238
1239     case STATUS_UNKNOWN:
1240     case STATUS_SCRATCH:
1241       crflag = O_CREAT;
1242       break;
1243
1244     case STATUS_REPLACE:
1245       crflag = O_CREAT | O_TRUNC;
1246       break;
1247
1248     default:
1249       internal_error (&opp->common, "regular_file(): Bad status");
1250     }
1251
1252   /* rwflag |= O_LARGEFILE; */
1253
1254 #if defined(HAVE_CRLF) && defined(O_BINARY)
1255   crflag |= O_BINARY;
1256 #endif
1257
1258   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1259   fd = open (path, rwflag | crflag, mode);
1260   if (flags->action != ACTION_UNSPECIFIED)
1261     return fd;
1262
1263   if (fd >= 0)
1264     {
1265       flags->action = ACTION_READWRITE;
1266       return fd;
1267     }
1268   if (errno != EACCES && errno != EROFS)
1269      return fd;
1270
1271   /* retry for read-only access */
1272   rwflag = O_RDONLY;
1273   fd = open (path, rwflag | crflag, mode);
1274   if (fd >=0)
1275     {
1276       flags->action = ACTION_READ;
1277       return fd;                /* success */
1278     }
1279
1280   if (errno != EACCES)
1281     return fd;                  /* failure */
1282
1283   /* retry for write-only access */
1284   rwflag = O_WRONLY;
1285   fd = open (path, rwflag | crflag, mode);
1286   if (fd >=0)
1287     {
1288       flags->action = ACTION_WRITE;
1289       return fd;                /* success */
1290     }
1291   return fd;                    /* failure */
1292 }
1293
1294
1295 /* open_external()-- Open an external file, unix specific version.
1296  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1297  * Returns NULL on operating system error. */
1298
1299 stream *
1300 open_external (st_parameter_open *opp, unit_flags *flags)
1301 {
1302   int fd;
1303
1304   if (flags->status == STATUS_SCRATCH)
1305     {
1306       fd = tempfile (opp);
1307       if (flags->action == ACTION_UNSPECIFIED)
1308         flags->action = ACTION_READWRITE;
1309
1310 #if HAVE_UNLINK_OPEN_FILE
1311       /* We can unlink scratch files now and it will go away when closed. */
1312       if (fd >= 0)
1313         unlink (opp->file);
1314 #endif
1315     }
1316   else
1317     {
1318       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1319        * if it succeeds */
1320       fd = regular_file (opp, flags);
1321     }
1322
1323   if (fd < 0)
1324     return NULL;
1325   fd = fix_fd (fd);
1326
1327   return fd_to_stream (fd);
1328 }
1329
1330
1331 /* input_stream()-- Return a stream pointer to the default input stream.
1332  * Called on initialization. */
1333
1334 stream *
1335 input_stream (void)
1336 {
1337   return fd_to_stream (STDIN_FILENO);
1338 }
1339
1340
1341 /* output_stream()-- Return a stream pointer to the default output stream.
1342  * Called on initialization. */
1343
1344 stream *
1345 output_stream (void)
1346 {
1347   stream * s;
1348
1349 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1350   setmode (STDOUT_FILENO, O_BINARY);
1351 #endif
1352
1353   s = fd_to_stream (STDOUT_FILENO);
1354   return s;
1355 }
1356
1357
1358 /* error_stream()-- Return a stream pointer to the default error stream.
1359  * Called on initialization. */
1360
1361 stream *
1362 error_stream (void)
1363 {
1364   stream * s;
1365
1366 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1367   setmode (STDERR_FILENO, O_BINARY);
1368 #endif
1369
1370   s = fd_to_stream (STDERR_FILENO);
1371   return s;
1372 }
1373
1374
1375 /* compare_file_filename()-- Given an open stream and a fortran string
1376  * that is a filename, figure out if the file is the same as the
1377  * filename. */
1378
1379 int
1380 compare_file_filename (gfc_unit *u, const char *name, int len)
1381 {
1382   char path[min(PATH_MAX, len + 1)];
1383   struct stat st;
1384 #ifdef HAVE_WORKING_STAT
1385   unix_stream *s;
1386 #else
1387 # ifdef __MINGW32__
1388   uint64_t id1, id2;
1389 # endif
1390 #endif
1391
1392   if (unpack_filename (path, name, len))
1393     return 0;                   /* Can't be the same */
1394
1395   /* If the filename doesn't exist, then there is no match with the
1396    * existing file. */
1397
1398   if (stat (path, &st) < 0)
1399     return 0;
1400
1401 #ifdef HAVE_WORKING_STAT
1402   s = (unix_stream *) (u->s);
1403   return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1404 #else
1405
1406 # ifdef __MINGW32__
1407   /* We try to match files by a unique ID.  On some filesystems (network
1408      fs and FAT), we can't generate this unique ID, and will simply compare
1409      filenames.  */
1410   id1 = id_from_path (path);
1411   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1412   if (id1 || id2)
1413     return (id1 == id2);
1414 # endif
1415
1416   if (len != u->file_len)
1417     return 0;
1418   return (memcmp(path, u->file, len) == 0);
1419 #endif
1420 }
1421
1422
1423 #ifdef HAVE_WORKING_STAT
1424 # define FIND_FILE0_DECL struct stat *st
1425 # define FIND_FILE0_ARGS st
1426 #else
1427 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1428 # define FIND_FILE0_ARGS id, file, file_len
1429 #endif
1430
1431 /* find_file0()-- Recursive work function for find_file() */
1432
1433 static gfc_unit *
1434 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1435 {
1436   gfc_unit *v;
1437 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1438   uint64_t id1;
1439 #endif
1440
1441   if (u == NULL)
1442     return NULL;
1443
1444 #ifdef HAVE_WORKING_STAT
1445   if (u->s != NULL)
1446     {
1447       unix_stream *s = (unix_stream *) (u->s);
1448       if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1449         return u;
1450     }
1451 #else
1452 # ifdef __MINGW32__
1453   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1454     {
1455       if (id == id1)
1456         return u;
1457     }
1458   else
1459 # endif
1460     if (compare_string (u->file_len, u->file, file_len, file) == 0)
1461       return u;
1462 #endif
1463
1464   v = find_file0 (u->left, FIND_FILE0_ARGS);
1465   if (v != NULL)
1466     return v;
1467
1468   v = find_file0 (u->right, FIND_FILE0_ARGS);
1469   if (v != NULL)
1470     return v;
1471
1472   return NULL;
1473 }
1474
1475
1476 /* find_file()-- Take the current filename and see if there is a unit
1477  * that has the file already open.  Returns a pointer to the unit if so. */
1478
1479 gfc_unit *
1480 find_file (const char *file, gfc_charlen_type file_len)
1481 {
1482   char path[min(PATH_MAX, file_len + 1)];
1483   struct stat st[1];
1484   gfc_unit *u;
1485 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1486   uint64_t id = 0ULL;
1487 #endif
1488
1489   if (unpack_filename (path, file, file_len))
1490     return NULL;
1491
1492   if (stat (path, &st[0]) < 0)
1493     return NULL;
1494
1495 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1496   id = id_from_path (path);
1497 #endif
1498
1499   __gthread_mutex_lock (&unit_lock);
1500 retry:
1501   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1502   if (u != NULL)
1503     {
1504       /* Fast path.  */
1505       if (! __gthread_mutex_trylock (&u->lock))
1506         {
1507           /* assert (u->closed == 0); */
1508           __gthread_mutex_unlock (&unit_lock);
1509           return u;
1510         }
1511
1512       inc_waiting_locked (u);
1513     }
1514   __gthread_mutex_unlock (&unit_lock);
1515   if (u != NULL)
1516     {
1517       __gthread_mutex_lock (&u->lock);
1518       if (u->closed)
1519         {
1520           __gthread_mutex_lock (&unit_lock);
1521           __gthread_mutex_unlock (&u->lock);
1522           if (predec_waiting_locked (u) == 0)
1523             free (u);
1524           goto retry;
1525         }
1526
1527       dec_waiting_unlocked (u);
1528     }
1529   return u;
1530 }
1531
1532 static gfc_unit *
1533 flush_all_units_1 (gfc_unit *u, int min_unit)
1534 {
1535   while (u != NULL)
1536     {
1537       if (u->unit_number > min_unit)
1538         {
1539           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1540           if (r != NULL)
1541             return r;
1542         }
1543       if (u->unit_number >= min_unit)
1544         {
1545           if (__gthread_mutex_trylock (&u->lock))
1546             return u;
1547           if (u->s)
1548             sflush (u->s);
1549           __gthread_mutex_unlock (&u->lock);
1550         }
1551       u = u->right;
1552     }
1553   return NULL;
1554 }
1555
1556 void
1557 flush_all_units (void)
1558 {
1559   gfc_unit *u;
1560   int min_unit = 0;
1561
1562   __gthread_mutex_lock (&unit_lock);
1563   do
1564     {
1565       u = flush_all_units_1 (unit_root, min_unit);
1566       if (u != NULL)
1567         inc_waiting_locked (u);
1568       __gthread_mutex_unlock (&unit_lock);
1569       if (u == NULL)
1570         return;
1571
1572       __gthread_mutex_lock (&u->lock);
1573
1574       min_unit = u->unit_number + 1;
1575
1576       if (u->closed == 0)
1577         {
1578           sflush (u->s);
1579           __gthread_mutex_lock (&unit_lock);
1580           __gthread_mutex_unlock (&u->lock);
1581           (void) predec_waiting_locked (u);
1582         }
1583       else
1584         {
1585           __gthread_mutex_lock (&unit_lock);
1586           __gthread_mutex_unlock (&u->lock);
1587           if (predec_waiting_locked (u) == 0)
1588             free (u);
1589         }
1590     }
1591   while (1);
1592 }
1593
1594
1595 /* delete_file()-- Given a unit structure, delete the file associated
1596  * with the unit.  Returns nonzero if something went wrong. */
1597
1598 int
1599 delete_file (gfc_unit * u)
1600 {
1601   char path[min(PATH_MAX, u->file_len + 1)];
1602   int err = unpack_filename (path, u->file, u->file_len);
1603
1604   if (err)
1605     {                           /* Shouldn't be possible */
1606       errno = err;
1607       return 1;
1608     }
1609
1610   return unlink (path);
1611 }
1612
1613
1614 /* file_exists()-- Returns nonzero if the current filename exists on
1615  * the system */
1616
1617 int
1618 file_exists (const char *file, gfc_charlen_type file_len)
1619 {
1620   char path[min(PATH_MAX, file_len + 1)];
1621
1622   if (unpack_filename (path, file, file_len))
1623     return 0;
1624
1625   return !(access (path, F_OK));
1626 }
1627
1628
1629 /* file_size()-- Returns the size of the file.  */
1630
1631 GFC_IO_INT
1632 file_size (const char *file, gfc_charlen_type file_len)
1633 {
1634   char path[min(PATH_MAX, file_len + 1)];
1635   struct stat statbuf;
1636
1637   if (unpack_filename (path, file, file_len))
1638     return -1;
1639
1640   if (stat (path, &statbuf) < 0)
1641     return -1;
1642
1643   return (GFC_IO_INT) statbuf.st_size;
1644 }
1645
1646 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1647
1648 /* inquire_sequential()-- Given a fortran string, determine if the
1649  * file is suitable for sequential access.  Returns a C-style
1650  * string. */
1651
1652 const char *
1653 inquire_sequential (const char *string, int len)
1654 {
1655   char path[min(PATH_MAX, len + 1)];
1656   struct stat statbuf;
1657
1658   if (string == NULL ||
1659       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1660     return unknown;
1661
1662   if (S_ISREG (statbuf.st_mode) ||
1663       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1664     return unknown;
1665
1666   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1667     return no;
1668
1669   return unknown;
1670 }
1671
1672
1673 /* inquire_direct()-- Given a fortran string, determine if the file is
1674  * suitable for direct access.  Returns a C-style string. */
1675
1676 const char *
1677 inquire_direct (const char *string, int len)
1678 {
1679   char path[min(PATH_MAX, len + 1)];
1680   struct stat statbuf;
1681
1682   if (string == NULL ||
1683       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1684     return unknown;
1685
1686   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1687     return unknown;
1688
1689   if (S_ISDIR (statbuf.st_mode) ||
1690       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1691     return no;
1692
1693   return unknown;
1694 }
1695
1696
1697 /* inquire_formatted()-- Given a fortran string, determine if the file
1698  * is suitable for formatted form.  Returns a C-style string. */
1699
1700 const char *
1701 inquire_formatted (const char *string, int len)
1702 {
1703   char path[min(PATH_MAX, len + 1)];
1704   struct stat statbuf;
1705
1706   if (string == NULL ||
1707       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1708     return unknown;
1709
1710   if (S_ISREG (statbuf.st_mode) ||
1711       S_ISBLK (statbuf.st_mode) ||
1712       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1713     return unknown;
1714
1715   if (S_ISDIR (statbuf.st_mode))
1716     return no;
1717
1718   return unknown;
1719 }
1720
1721
1722 /* inquire_unformatted()-- Given a fortran string, determine if the file
1723  * is suitable for unformatted form.  Returns a C-style string. */
1724
1725 const char *
1726 inquire_unformatted (const char *string, int len)
1727 {
1728   return inquire_formatted (string, len);
1729 }
1730
1731
1732 /* inquire_access()-- Given a fortran string, determine if the file is
1733  * suitable for access. */
1734
1735 static const char *
1736 inquire_access (const char *string, int len, int mode)
1737 {
1738   char path[min(PATH_MAX, len + 1)];
1739
1740   if (string == NULL || unpack_filename (path, string, len) ||
1741       access (path, mode) < 0)
1742     return no;
1743
1744   return yes;
1745 }
1746
1747
1748 /* inquire_read()-- Given a fortran string, determine if the file is
1749  * suitable for READ access. */
1750
1751 const char *
1752 inquire_read (const char *string, int len)
1753 {
1754   return inquire_access (string, len, R_OK);
1755 }
1756
1757
1758 /* inquire_write()-- Given a fortran string, determine if the file is
1759  * suitable for READ access. */
1760
1761 const char *
1762 inquire_write (const char *string, int len)
1763 {
1764   return inquire_access (string, len, W_OK);
1765 }
1766
1767
1768 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1769  * suitable for read and write access. */
1770
1771 const char *
1772 inquire_readwrite (const char *string, int len)
1773 {
1774   return inquire_access (string, len, R_OK | W_OK);
1775 }
1776
1777
1778 int
1779 stream_isatty (stream *s)
1780 {
1781   return isatty (((unix_stream *) s)->fd);
1782 }
1783
1784 int
1785 stream_ttyname (stream *s  __attribute__ ((unused)),
1786                 char * buf  __attribute__ ((unused)),
1787                 size_t buflen  __attribute__ ((unused)))
1788 {
1789 #ifdef HAVE_TTYNAME_R
1790   return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1791 #elif defined HAVE_TTYNAME
1792   char *p;
1793   size_t plen;
1794   p = ttyname (((unix_stream *) s)->fd);
1795   if (!p)
1796     return errno;
1797   plen = strlen (p);
1798   if (buflen < plen)
1799     plen = buflen;
1800   memcpy (buf, p, plen);
1801   return 0;
1802 #else
1803   return ENOSYS;
1804 #endif
1805 }
1806
1807
1808
1809
1810 /* How files are stored:  This is an operating-system specific issue,
1811    and therefore belongs here.  There are three cases to consider.
1812
1813    Direct Access:
1814       Records are written as block of bytes corresponding to the record
1815       length of the file.  This goes for both formatted and unformatted
1816       records.  Positioning is done explicitly for each data transfer,
1817       so positioning is not much of an issue.
1818
1819    Sequential Formatted:
1820       Records are separated by newline characters.  The newline character
1821       is prohibited from appearing in a string.  If it does, this will be
1822       messed up on the next read.  End of file is also the end of a record.
1823
1824    Sequential Unformatted:
1825       In this case, we are merely copying bytes to and from main storage,
1826       yet we need to keep track of varying record lengths.  We adopt
1827       the solution used by f2c.  Each record contains a pair of length
1828       markers:
1829
1830         Length of record n in bytes
1831         Data of record n
1832         Length of record n in bytes
1833
1834         Length of record n+1 in bytes
1835         Data of record n+1
1836         Length of record n+1 in bytes
1837
1838      The length is stored at the end of a record to allow backspacing to the
1839      previous record.  Between data transfer statements, the file pointer
1840      is left pointing to the first length of the current record.
1841
1842      ENDFILE records are never explicitly stored.
1843
1844 */