libgfortran/io/unix.c

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