libgfortran/io/unix.c

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