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 (s->ndirty == 0)
 586     s->buffer_offset = s->logical_offset;
 587
 588   /* Does the data fit into the buffer?  As a special case, if the
 589      buffer is empty and the request is bigger than BUFFER_SIZE/2,
 590      write directly. This avoids the case where the buffer would have
 591      to be flushed at every write.  */
 592   if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
 593       && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
 594       && s->buffer_offset <= s->logical_offset
 595       && s->buffer_offset + s->ndirty >= s->logical_offset)
 596     {
 597       memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
 598       int nd = (s->logical_offset - s->buffer_offset) + nbyte;
 599       if (nd > s->ndirty)
 600         s->ndirty = nd;
 601     }
 602   else
 603     {
 604       /* Flush, and either fill the buffer with the new data, or if
 605          the request is bigger than the buffer size, write directly
 606          bypassing the buffer.  */
 607       buf_flush (s);
 608       if (nbyte <= BUFFER_SIZE/2)
 609         {
 610           memcpy (s->buffer, buf, nbyte);
 611           s->buffer_offset = s->logical_offset;
 612           s->ndirty += nbyte;
 613         }
 614       else
 615         {
 616           if (s->physical_offset != s->logical_offset)
 617             {
 618               if (raw_seek (s, s->logical_offset, SEEK_SET) < 0)
 619                 return -1;
 620               s->physical_offset = s->logical_offset;
 621             }
 622
 623           nbyte = raw_write (s, buf, nbyte);
 624           s->physical_offset += nbyte;
 625         }
 626     }
 627   s->logical_offset += nbyte;
 628   if (s->logical_offset > s->file_length)
 629     s->file_length = s->logical_offset;
 630   return nbyte;
 631 }
 632
 633
 634 /* "Unbuffered" really means I/O statement buffering. For formatted
 635    I/O, the fbuf manages this, and then uses raw I/O. For unformatted
 636    I/O, buffered I/O is used, and the buffer is flushed at the end of
 637    each I/O statement, where this function is called.  Alternatively,
 638    the buffer is flushed at the end of the record if the buffer is
 639    more than half full; this prevents needless seeking back and forth
 640    when writing sequential unformatted.  */
 641
 642 static int
 643 buf_markeor (unix_stream * s)
 644 {
 645   if (s->unbuffered || s->ndirty >= BUFFER_SIZE / 2)
 646     return buf_flush (s);
 647   return 0;
 648 }
 649
 650 static gfc_offset
 651 buf_seek (unix_stream * s, gfc_offset offset, int whence)
 652 {
 653   switch (whence)
 654     {
 655     case SEEK_SET:
 656       break;
 657     case SEEK_CUR:
 658       offset += s->logical_offset;
 659       break;
 660     case SEEK_END:
 661       offset += s->file_length;
 662       break;
 663     default:
 664       return -1;
 665     }
 666   if (offset < 0)
 667     {
 668       errno = EINVAL;
 669       return -1;
 670     }
 671   s->logical_offset = offset;
 672   return offset;
 673 }
 674
 675 static gfc_offset
 676 buf_tell (unix_stream * s)
 677 {
 678   return buf_seek (s, 0, SEEK_CUR);
 679 }
 680
 681 static gfc_offset
 682 buf_size (unix_stream * s)
 683 {
 684   return s->file_length;
 685 }
 686
 687 static int
 688 buf_truncate (unix_stream * s, gfc_offset length)
 689 {
 690   int r;
 691
 692   if (buf_flush (s) != 0)
 693     return -1;
 694   r = raw_truncate (s, length);
 695   if (r == 0)
 696     s->file_length = length;
 697   return r;
 698 }
 699
 700 static int
 701 buf_close (unix_stream * s)
 702 {
 703   if (buf_flush (s) != 0)
 704     return -1;
 705   free (s->buffer);
 706   return raw_close (s);
 707 }
 708
 709 static const struct stream_vtable buf_vtable = {
 710   .read = (void *) buf_read,
 711   .write = (void *) buf_write,
 712   .seek = (void *) buf_seek,
 713   .tell = (void *) buf_tell,
 714   .size = (void *) buf_size,
 715   .trunc = (void *) buf_truncate,
 716   .close = (void *) buf_close,
 717   .flush = (void *) buf_flush,
 718   .markeor = (void *) buf_markeor
 719 };
 720
 721 static int
 722 buf_init (unix_stream * s)
 723 {
 724   s->st.vptr = &buf_vtable;
 725
 726   s->buffer = xmalloc (BUFFER_SIZE);
 727   return 0;
 728 }
 729
 730
 731 /*********************************************************************
 732   memory stream functions - These are used for internal files
 733
 734   The idea here is that a single stream structure is created and all
 735   requests must be satisfied from it.  The location and size of the
 736   buffer is the character variable supplied to the READ or WRITE
 737   statement.
 738
 739 *********************************************************************/
 740
 741 char *
 742 mem_alloc_r (stream * strm, int * len)
 743 {
 744   unix_stream * s = (unix_stream *) strm;
 745   gfc_offset n;
 746   gfc_offset where = s->logical_offset;
 747
 748   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 749     return NULL;
 750
 751   n = s->buffer_offset + s->active - where;
 752   if (*len > n)
 753     *len = n;
 754
 755   s->logical_offset = where + *len;
 756
 757   return s->buffer + (where - s->buffer_offset);
 758 }
 759
 760
 761 char *
 762 mem_alloc_r4 (stream * strm, int * len)
 763 {
 764   unix_stream * s = (unix_stream *) strm;
 765   gfc_offset n;
 766   gfc_offset where = s->logical_offset;
 767
 768   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
 769     return NULL;
 770
 771   n = s->buffer_offset + s->active - where;
 772   if (*len > n)
 773     *len = n;
 774
 775   s->logical_offset = where + *len;
 776
 777   return s->buffer + (where - s->buffer_offset) * 4;
 778 }
 779
 780
 781 char *
 782 mem_alloc_w (stream * strm, int * len)
 783 {
 784   unix_stream * s = (unix_stream *) strm;
 785   gfc_offset m;
 786   gfc_offset where = s->logical_offset;
 787
 788   m = where + *len;
 789
 790   if (where < s->buffer_offset)
 791     return NULL;
 792
 793   if (m > s->file_length)
 794     return NULL;
 795
 796   s->logical_offset = m;
 797
 798   return s->buffer + (where - s->buffer_offset);
 799 }
 800
 801
 802 gfc_char4_t *
 803 mem_alloc_w4 (stream * strm, int * len)
 804 {
 805   unix_stream * s = (unix_stream *) strm;
 806   gfc_offset m;
 807   gfc_offset where = s->logical_offset;
 808   gfc_char4_t *result = (gfc_char4_t *) s->buffer;
 809
 810   m = where + *len;
 811
 812   if (where < s->buffer_offset)
 813     return NULL;
 814
 815   if (m > s->file_length)
 816     return NULL;
 817
 818   s->logical_offset = m;
 819   return &result[where - s->buffer_offset];
 820 }
 821
 822
 823 /* Stream read function for character(kind=1) internal units.  */
 824
 825 static ssize_t
 826 mem_read (stream * s, void * buf, ssize_t nbytes)
 827 {
 828   void *p;
 829   int nb = nbytes;
 830
 831   p = mem_alloc_r (s, &nb);
 832   if (p)
 833     {
 834       memcpy (buf, p, nb);
 835       return (ssize_t) nb;
 836     }
 837   else
 838     return 0;
 839 }
 840
 841
 842 /* Stream read function for chracter(kind=4) internal units.  */
 843
 844 static ssize_t
 845 mem_read4 (stream * s, void * buf, ssize_t nbytes)
 846 {
 847   void *p;
 848   int nb = nbytes;
 849
 850   p = mem_alloc_r4 (s, &nb);
 851   if (p)
 852     {
 853       memcpy (buf, p, nb * 4);
 854       return (ssize_t) nb;
 855     }
 856   else
 857     return 0;
 858 }
 859
 860
 861 /* Stream write function for character(kind=1) internal units.  */
 862
 863 static ssize_t
 864 mem_write (stream * s, const void * buf, ssize_t nbytes)
 865 {
 866   void *p;
 867   int nb = nbytes;
 868
 869   p = mem_alloc_w (s, &nb);
 870   if (p)
 871     {
 872       memcpy (p, buf, nb);
 873       return (ssize_t) nb;
 874     }
 875   else
 876     return 0;
 877 }
 878
 879
 880 /* Stream write function for character(kind=4) internal units.  */
 881
 882 static ssize_t
 883 mem_write4 (stream * s, const void * buf, ssize_t nwords)
 884 {
 885   gfc_char4_t *p;
 886   int nw = nwords;
 887
 888   p = mem_alloc_w4 (s, &nw);
 889   if (p)
 890     {
 891       while (nw--)
 892         *p++ = (gfc_char4_t) *((char *) buf);
 893       return nwords;
 894     }
 895   else
 896     return 0;
 897 }
 898
 899
 900 static gfc_offset
 901 mem_seek (stream * strm, gfc_offset offset, int whence)
 902 {
 903   unix_stream * s = (unix_stream *) strm;
 904   switch (whence)
 905     {
 906     case SEEK_SET:
 907       break;
 908     case SEEK_CUR:
 909       offset += s->logical_offset;
 910       break;
 911     case SEEK_END:
 912       offset += s->file_length;
 913       break;
 914     default:
 915       return -1;
 916     }
 917
 918   /* Note that for internal array I/O it's actually possible to have a
 919      negative offset, so don't check for that.  */
 920   if (offset > s->file_length)
 921     {
 922       errno = EINVAL;
 923       return -1;
 924     }
 925
 926   s->logical_offset = offset;
 927
 928   /* Returning < 0 is the error indicator for sseek(), so return 0 if
 929      offset is negative.  Thus if the return value is 0, the caller
 930      has to use stell() to get the real value of logical_offset.  */
 931   if (offset >= 0)
 932     return offset;
 933   return 0;
 934 }
 935
 936
 937 static gfc_offset
 938 mem_tell (stream * s)
 939 {
 940   return ((unix_stream *)s)->logical_offset;
 941 }
 942
 943
 944 static int
 945 mem_truncate (unix_stream * s __attribute__ ((unused)),
 946               gfc_offset length __attribute__ ((unused)))
 947 {
 948   return 0;
 949 }
 950
 951
 952 static int
 953 mem_flush (unix_stream * s __attribute__ ((unused)))
 954 {
 955   return 0;
 956 }
 957
 958
 959 static int
 960 mem_close (unix_stream * s)
 961 {
 962   free (s);
 963
 964   return 0;
 965 }
 966
 967 static const struct stream_vtable mem_vtable = {
 968   .read = (void *) mem_read,
 969   .write = (void *) mem_write,
 970   .seek = (void *) mem_seek,
 971   .tell = (void *) mem_tell,
 972   /* buf_size is not a typo, we just reuse an identical
 973      implementation.  */
 974   .size = (void *) buf_size,
 975   .trunc = (void *) mem_truncate,
 976   .close = (void *) mem_close,
 977   .flush = (void *) mem_flush,
 978   .markeor = (void *) raw_markeor
 979 };
 980
 981 static const struct stream_vtable mem4_vtable = {
 982   .read = (void *) mem_read4,
 983   .write = (void *) mem_write4,
 984   .seek = (void *) mem_seek,
 985   .tell = (void *) mem_tell,
 986   /* buf_size is not a typo, we just reuse an identical
 987      implementation.  */
 988   .size = (void *) buf_size,
 989   .trunc = (void *) mem_truncate,
 990   .close = (void *) mem_close,
 991   .flush = (void *) mem_flush,
 992   .markeor = (void *) raw_markeor
 993 };
 994
 995 /*********************************************************************
 996   Public functions -- A reimplementation of this module needs to
 997   define functional equivalents of the following.
 998 *********************************************************************/
 999
1000 /* open_internal()-- Returns a stream structure from a character(kind=1)
1001    internal file */
1002
1003 stream *
1004 open_internal (char *base, int length, gfc_offset offset)
1005 {
1006   unix_stream *s;
1007
1008   s = xcalloc (1, sizeof (unix_stream));
1009
1010   s->buffer = base;
1011   s->buffer_offset = offset;
1012
1013   s->active = s->file_length = length;
1014
1015   s->st.vptr = &mem_vtable;
1016
1017   return (stream *) s;
1018 }
1019
1020 /* open_internal4()-- Returns a stream structure from a character(kind=4)
1021    internal file */
1022
1023 stream *
1024 open_internal4 (char *base, int length, gfc_offset offset)
1025 {
1026   unix_stream *s;
1027
1028   s = xcalloc (1, sizeof (unix_stream));
1029
1030   s->buffer = base;
1031   s->buffer_offset = offset;
1032
1033   s->active = s->file_length = length * sizeof (gfc_char4_t);
1034
1035   s->st.vptr = &mem4_vtable;
1036
1037   return (stream *) s;
1038 }
1039
1040
1041 /* fd_to_stream()-- Given an open file descriptor, build a stream
1042  * around it. */
1043
1044 static stream *
1045 fd_to_stream (int fd, bool unformatted)
1046 {
1047   struct stat statbuf;
1048   unix_stream *s;
1049
1050   s = xcalloc (1, sizeof (unix_stream));
1051
1052   s->fd = fd;
1053
1054   /* Get the current length of the file. */
1055
1056   if (TEMP_FAILURE_RETRY (fstat (fd, &statbuf)) == -1)
1057     {
1058       s->st_dev = s->st_ino = -1;
1059       s->file_length = 0;
1060       if (errno == EBADF)
1061         s->fd = -1;
1062       raw_init (s);
1063       return (stream *) s;
1064     }
1065
1066   s->st_dev = statbuf.st_dev;
1067   s->st_ino = statbuf.st_ino;
1068   s->file_length = statbuf.st_size;
1069
1070   /* Only use buffered IO for regular files.  */
1071   if (S_ISREG (statbuf.st_mode)
1072       && !options.all_unbuffered
1073       && !(options.unbuffered_preconnected &&
1074            (s->fd == STDIN_FILENO
1075             || s->fd == STDOUT_FILENO
1076             || s->fd == STDERR_FILENO)))
1077     buf_init (s);
1078   else
1079     {
1080       if (unformatted)
1081         {
1082           s->unbuffered = true;
1083           buf_init (s);
1084         }
1085       else
1086         raw_init (s);
1087     }
1088
1089   return (stream *) s;
1090 }
1091
1092
1093 /* Given the Fortran unit number, convert it to a C file descriptor.  */
1094
1095 int
1096 unit_to_fd (int unit)
1097 {
1098   gfc_unit *us;
1099   int fd;
1100
1101   us = find_unit (unit);
1102   if (us == NULL)
1103     return -1;
1104
1105   fd = ((unix_stream *) us->s)->fd;
1106   unlock_unit (us);
1107   return fd;
1108 }
1109
1110
1111 /* Set the close-on-exec flag for an existing fd, if the system
1112    supports such.  */
1113
1114 static void __attribute__ ((unused))
1115 set_close_on_exec (int fd __attribute__ ((unused)))
1116 {
1117   /* Mingw does not define F_SETFD.  */
1118 #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1119   if (fd >= 0)
1120     fcntl(fd, F_SETFD, FD_CLOEXEC);
1121 #endif
1122 }
1123
1124
1125 /* Helper function for tempfile(). Tries to open a temporary file in
1126    the directory specified by tempdir. If successful, the file name is
1127    stored in fname and the descriptor returned. Returns -1 on
1128    failure.  */
1129
1130 static int
1131 tempfile_open (const char *tempdir, char **fname)
1132 {
1133   int fd;
1134   const char *slash = "/";
1135 #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1136   mode_t mode_mask;
1137 #endif
1138
1139   if (!tempdir)
1140     return -1;
1141
1142   /* Check for the special case that tempdir ends with a slash or
1143      backslash.  */
1144   size_t tempdirlen = strlen (tempdir);
1145   if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1146 #ifdef __MINGW32__
1147       || tempdir[tempdirlen - 1] == '\\'
1148 #endif
1149      )
1150     slash = "";
1151
1152   /* Take care that the template is longer in the mktemp() branch.  */
1153   char * template = xmalloc (tempdirlen + 23);
1154
1155 #ifdef HAVE_MKSTEMP
1156   snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1157             tempdir, slash);
1158
1159 #ifdef HAVE_UMASK
1160   /* Temporarily set the umask such that the file has 0600 permissions.  */
1161   mode_mask = umask (S_IXUSR | S_IRWXG | S_IRWXO);
1162 #endif
1163
1164 #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1165   TEMP_FAILURE_RETRY (fd = mkostemp (template, O_CLOEXEC));
1166 #else
1167   TEMP_FAILURE_RETRY (fd = mkstemp (template));
1168   set_close_on_exec (fd);
1169 #endif
1170
1171 #ifdef HAVE_UMASK
1172   (void) umask (mode_mask);
1173 #endif
1174
1175 #else /* HAVE_MKSTEMP */
1176   fd = -1;
1177   int count = 0;
1178   size_t slashlen = strlen (slash);
1179   int flags = O_RDWR | O_CREAT | O_EXCL;
1180 #if defined(HAVE_CRLF) && defined(O_BINARY)
1181   flags |= O_BINARY;
1182 #endif
1183 #ifdef O_CLOEXEC
1184   flags |= O_CLOEXEC;
1185 #endif
1186   do
1187     {
1188       snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1189                 tempdir, slash);
1190       if (count > 0)
1191         {
1192           int c = count;
1193           template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1194           c /= 26;
1195           template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1196           c /= 26;
1197           template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1198           if (c >= 26)
1199             break;
1200         }
1201
1202       if (!mktemp (template))
1203       {
1204         errno = EEXIST;
1205         count++;
1206         continue;
1207       }
1208
1209       TEMP_FAILURE_RETRY (fd = open (template, flags, S_IRUSR | S_IWUSR));
1210     }
1211   while (fd == -1 && errno == EEXIST);
1212 #ifndef O_CLOEXEC
1213   set_close_on_exec (fd);
1214 #endif
1215 #endif /* HAVE_MKSTEMP */
1216
1217   *fname = template;
1218   return fd;
1219 }
1220
1221
1222 /* tempfile()-- Generate a temporary filename for a scratch file and
1223  * open it.  mkstemp() opens the file for reading and writing, but the
1224  * library mode prevents anything that is not allowed.  The descriptor
1225  * is returned, which is -1 on error.  The template is pointed to by
1226  * opp->file, which is copied into the unit structure
1227  * and freed later. */
1228
1229 static int
1230 tempfile (st_parameter_open *opp)
1231 {
1232   const char *tempdir;
1233   char *fname;
1234   int fd = -1;
1235
1236   tempdir = secure_getenv ("TMPDIR");
1237   fd = tempfile_open (tempdir, &fname);
1238 #ifdef __MINGW32__
1239   if (fd == -1)
1240     {
1241       char buffer[MAX_PATH + 1];
1242       DWORD ret;
1243       ret = GetTempPath (MAX_PATH, buffer);
1244       /* If we are not able to get a temp-directory, we use
1245          current directory.  */
1246       if (ret > MAX_PATH || !ret)
1247         buffer[0] = 0;
1248       else
1249         buffer[ret] = 0;
1250       tempdir = strdup (buffer);
1251       fd = tempfile_open (tempdir, &fname);
1252     }
1253 #elif defined(__CYGWIN__)
1254   if (fd == -1)
1255     {
1256       tempdir = secure_getenv ("TMP");
1257       fd = tempfile_open (tempdir, &fname);
1258     }
1259   if (fd == -1)
1260     {
1261       tempdir = secure_getenv ("TEMP");
1262       fd = tempfile_open (tempdir, &fname);
1263     }
1264 #endif
1265   if (fd == -1)
1266     fd = tempfile_open (P_tmpdir, &fname);
1267
1268   opp->file = fname;
1269   opp->file_len = strlen (fname);       /* Don't include trailing nul */
1270
1271   return fd;
1272 }
1273
1274
1275 /* regular_file2()-- Open a regular file.
1276  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1277  * unless an error occurs.
1278  * Returns the descriptor, which is less than zero on error. */
1279
1280 static int
1281 regular_file2 (const char *path, st_parameter_open *opp, unit_flags *flags)
1282 {
1283   int mode;
1284   int rwflag;
1285   int crflag, crflag2;
1286   int fd;
1287
1288 #ifdef __CYGWIN__
1289   if (opp->file_len == 7)
1290     {
1291       if (strncmp (path, "CONOUT$", 7) == 0
1292           || strncmp (path, "CONERR$", 7) == 0)
1293         {
1294           fd = open ("/dev/conout", O_WRONLY);
1295           flags->action = ACTION_WRITE;
1296           return fd;
1297         }
1298     }
1299
1300   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1301     {
1302       fd = open ("/dev/conin", O_RDONLY);
1303       flags->action = ACTION_READ;
1304       return fd;
1305     }
1306 #endif
1307
1308
1309 #ifdef __MINGW32__
1310   if (opp->file_len == 7)
1311     {
1312       if (strncmp (path, "CONOUT$", 7) == 0
1313           || strncmp (path, "CONERR$", 7) == 0)
1314         {
1315           fd = open ("CONOUT$", O_WRONLY);
1316           flags->action = ACTION_WRITE;
1317           return fd;
1318         }
1319     }
1320
1321   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1322     {
1323       fd = open ("CONIN$", O_RDONLY);
1324       flags->action = ACTION_READ;
1325       return fd;
1326     }
1327 #endif
1328
1329   switch (flags->action)
1330     {
1331     case ACTION_READ:
1332       rwflag = O_RDONLY;
1333       break;
1334
1335     case ACTION_WRITE:
1336       rwflag = O_WRONLY;
1337       break;
1338
1339     case ACTION_READWRITE:
1340     case ACTION_UNSPECIFIED:
1341       rwflag = O_RDWR;
1342       break;
1343
1344     default:
1345       internal_error (&opp->common, "regular_file(): Bad action");
1346     }
1347
1348   switch (flags->status)
1349     {
1350     case STATUS_NEW:
1351       crflag = O_CREAT | O_EXCL;
1352       break;
1353
1354     case STATUS_OLD:            /* open will fail if the file does not exist*/
1355       crflag = 0;
1356       break;
1357
1358     case STATUS_UNKNOWN:
1359       if (rwflag == O_RDONLY)
1360         crflag = 0;
1361       else
1362         crflag = O_CREAT;
1363       break;
1364
1365     case STATUS_REPLACE:
1366       crflag = O_CREAT | O_TRUNC;
1367       break;
1368
1369     default:
1370       /* Note: STATUS_SCRATCH is handled by tempfile () and should
1371          never be seen here.  */
1372       internal_error (&opp->common, "regular_file(): Bad status");
1373     }
1374
1375   /* rwflag |= O_LARGEFILE; */
1376
1377 #if defined(HAVE_CRLF) && defined(O_BINARY)
1378   crflag |= O_BINARY;
1379 #endif
1380
1381 #ifdef O_CLOEXEC
1382   crflag |= O_CLOEXEC;
1383 #endif
1384
1385   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1386   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1387   if (flags->action != ACTION_UNSPECIFIED)
1388     return fd;
1389
1390   if (fd >= 0)
1391     {
1392       flags->action = ACTION_READWRITE;
1393       return fd;
1394     }
1395   if (errno != EACCES && errno != EPERM && errno != EROFS)
1396      return fd;
1397
1398   /* retry for read-only access */
1399   rwflag = O_RDONLY;
1400   if (flags->status == STATUS_UNKNOWN)
1401     crflag2 = crflag & ~(O_CREAT);
1402   else
1403     crflag2 = crflag;
1404   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag2, mode));
1405   if (fd >=0)
1406     {
1407       flags->action = ACTION_READ;
1408       return fd;                /* success */
1409     }
1410
1411   if (errno != EACCES && errno != EPERM && errno != ENOENT)
1412     return fd;                  /* failure */
1413
1414   /* retry for write-only access */
1415   rwflag = O_WRONLY;
1416   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1417   if (fd >=0)
1418     {
1419       flags->action = ACTION_WRITE;
1420       return fd;                /* success */
1421     }
1422   return fd;                    /* failure */
1423 }
1424
1425
1426 /* Lock the file, if necessary, based on SHARE flags.  */
1427
1428 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1429 static int
1430 open_share (st_parameter_open *opp, int fd, unit_flags *flags)
1431 {
1432   int r = 0;
1433   struct flock f;
1434   if (fd == STDOUT_FILENO || fd == STDERR_FILENO || fd == STDIN_FILENO)
1435     return 0;
1436
1437   f.l_start = 0;
1438   f.l_len = 0;
1439   f.l_whence = SEEK_SET;
1440
1441   switch (flags->share)
1442   {
1443     case SHARE_DENYNONE:
1444       f.l_type = F_RDLCK;
1445       r = fcntl (fd, F_SETLK, &f);
1446       break;
1447     case SHARE_DENYRW:
1448       /* Must be writable to hold write lock.  */
1449       if (flags->action == ACTION_READ)
1450         {
1451           generate_error (&opp->common, LIBERROR_BAD_ACTION,
1452               "Cannot set write lock on file opened for READ");
1453           return -1;
1454         }
1455       f.l_type = F_WRLCK;
1456       r = fcntl (fd, F_SETLK, &f);
1457       break;
1458     case SHARE_UNSPECIFIED:
1459     default:
1460       break;
1461   }
1462
1463   return r;
1464 }
1465 #else
1466 static int
1467 open_share (st_parameter_open *opp __attribute__ ((unused)),
1468     int fd __attribute__ ((unused)),
1469     unit_flags *flags __attribute__ ((unused)))
1470 {
1471   return 0;
1472 }
1473 #endif /* defined(HAVE_FCNTL) ... */
1474
1475
1476 /* Wrapper around regular_file2, to make sure we free the path after
1477    we're done.  */
1478
1479 static int
1480 regular_file (st_parameter_open *opp, unit_flags *flags)
1481 {
1482   char *path = fc_strdup (opp->file, opp->file_len);
1483   int fd = regular_file2 (path, opp, flags);
1484   free (path);
1485   return fd;
1486 }
1487
1488 /* open_external()-- Open an external file, unix specific version.
1489  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1490  * Returns NULL on operating system error. */
1491
1492 stream *
1493 open_external (st_parameter_open *opp, unit_flags *flags)
1494 {
1495   int fd;
1496
1497   if (flags->status == STATUS_SCRATCH)
1498     {
1499       fd = tempfile (opp);
1500       if (flags->action == ACTION_UNSPECIFIED)
1501         flags->action = flags->readonly ? ACTION_READ : ACTION_READWRITE;
1502
1503 #if HAVE_UNLINK_OPEN_FILE
1504       /* We can unlink scratch files now and it will go away when closed. */
1505       if (fd >= 0)
1506         unlink (opp->file);
1507 #endif
1508     }
1509   else
1510     {
1511       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1512        * if it succeeds */
1513       fd = regular_file (opp, flags);
1514 #ifndef O_CLOEXEC
1515       set_close_on_exec (fd);
1516 #endif
1517     }
1518
1519   if (fd < 0)
1520     return NULL;
1521   fd = fix_fd (fd);
1522
1523   if (open_share (opp, fd, flags) < 0)
1524     return NULL;
1525
1526   return fd_to_stream (fd, flags->form == FORM_UNFORMATTED);
1527 }
1528
1529
1530 /* input_stream()-- Return a stream pointer to the default input stream.
1531  * Called on initialization. */
1532
1533 stream *
1534 input_stream (void)
1535 {
1536   return fd_to_stream (STDIN_FILENO, false);
1537 }
1538
1539
1540 /* output_stream()-- Return a stream pointer to the default output stream.
1541  * Called on initialization. */
1542
1543 stream *
1544 output_stream (void)
1545 {
1546   stream * s;
1547
1548 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1549   setmode (STDOUT_FILENO, O_BINARY);
1550 #endif
1551
1552   s = fd_to_stream (STDOUT_FILENO, false);
1553   return s;
1554 }
1555
1556
1557 /* error_stream()-- Return a stream pointer to the default error stream.
1558  * Called on initialization. */
1559
1560 stream *
1561 error_stream (void)
1562 {
1563   stream * s;
1564
1565 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1566   setmode (STDERR_FILENO, O_BINARY);
1567 #endif
1568
1569   s = fd_to_stream (STDERR_FILENO, false);
1570   return s;
1571 }
1572
1573
1574 /* compare_file_filename()-- Given an open stream and a fortran string
1575  * that is a filename, figure out if the file is the same as the
1576  * filename. */
1577
1578 int
1579 compare_file_filename (gfc_unit *u, const char *name, int len)
1580 {
1581   struct stat st;
1582   int ret;
1583 #ifdef HAVE_WORKING_STAT
1584   unix_stream *s;
1585 #else
1586 # ifdef __MINGW32__
1587   uint64_t id1, id2;
1588 # endif
1589 #endif
1590
1591   char *path = fc_strdup (name, len);
1592
1593   /* If the filename doesn't exist, then there is no match with the
1594    * existing file. */
1595
1596   if (TEMP_FAILURE_RETRY (stat (path, &st)) < 0)
1597     {
1598       ret = 0;
1599       goto done;
1600     }
1601
1602 #ifdef HAVE_WORKING_STAT
1603   s = (unix_stream *) (u->s);
1604   ret = (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1605   goto done;
1606 #else
1607
1608 # ifdef __MINGW32__
1609   /* We try to match files by a unique ID.  On some filesystems (network
1610      fs and FAT), we can't generate this unique ID, and will simply compare
1611      filenames.  */
1612   id1 = id_from_path (path);
1613   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1614   if (id1 || id2)
1615     {
1616       ret = (id1 == id2);
1617       goto done;
1618     }
1619 # endif
1620   if (u->filename)
1621     ret = (strcmp(path, u->filename) == 0);
1622   else
1623     ret = 0;
1624 #endif
1625  done:
1626   free (path);
1627   return ret;
1628 }
1629
1630
1631 #ifdef HAVE_WORKING_STAT
1632 # define FIND_FILE0_DECL struct stat *st
1633 # define FIND_FILE0_ARGS st
1634 #else
1635 # define FIND_FILE0_DECL uint64_t id, const char *path
1636 # define FIND_FILE0_ARGS id, path
1637 #endif
1638
1639 /* find_file0()-- Recursive work function for find_file() */
1640
1641 static gfc_unit *
1642 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1643 {
1644   gfc_unit *v;
1645 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1646   uint64_t id1;
1647 #endif
1648
1649   if (u == NULL)
1650     return NULL;
1651
1652 #ifdef HAVE_WORKING_STAT
1653   if (u->s != NULL)
1654     {
1655       unix_stream *s = (unix_stream *) (u->s);
1656       if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1657         return u;
1658     }
1659 #else
1660 # ifdef __MINGW32__
1661   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1662     {
1663       if (id == id1)
1664         return u;
1665     }
1666   else
1667 # endif
1668     if (u->filename && strcmp (u->filename, path) == 0)
1669       return u;
1670 #endif
1671
1672   v = find_file0 (u->left, FIND_FILE0_ARGS);
1673   if (v != NULL)
1674     return v;
1675
1676   v = find_file0 (u->right, FIND_FILE0_ARGS);
1677   if (v != NULL)
1678     return v;
1679
1680   return NULL;
1681 }
1682
1683
1684 /* find_file()-- Take the current filename and see if there is a unit
1685  * that has the file already open.  Returns a pointer to the unit if so. */
1686
1687 gfc_unit *
1688 find_file (const char *file, gfc_charlen_type file_len)
1689 {
1690   struct stat st[1];
1691   gfc_unit *u;
1692 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1693   uint64_t id = 0ULL;
1694 #endif
1695
1696   char *path = fc_strdup (file, file_len);
1697
1698   if (TEMP_FAILURE_RETRY (stat (path, &st[0])) < 0)
1699     {
1700       u = NULL;
1701       goto done;
1702     }
1703
1704 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1705   id = id_from_path (path);
1706 #endif
1707
1708   __gthread_mutex_lock (&unit_lock);
1709 retry:
1710   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1711   if (u != NULL)
1712     {
1713       /* Fast path.  */
1714       if (! __gthread_mutex_trylock (&u->lock))
1715         {
1716           /* assert (u->closed == 0); */
1717           __gthread_mutex_unlock (&unit_lock);
1718           goto done;
1719         }
1720
1721       inc_waiting_locked (u);
1722     }
1723   __gthread_mutex_unlock (&unit_lock);
1724   if (u != NULL)
1725     {
1726       __gthread_mutex_lock (&u->lock);
1727       if (u->closed)
1728         {
1729           __gthread_mutex_lock (&unit_lock);
1730           __gthread_mutex_unlock (&u->lock);
1731           if (predec_waiting_locked (u) == 0)
1732             free (u);
1733           goto retry;
1734         }
1735
1736       dec_waiting_unlocked (u);
1737     }
1738  done:
1739   free (path);
1740   return u;
1741 }
1742
1743 static gfc_unit *
1744 flush_all_units_1 (gfc_unit *u, int min_unit)
1745 {
1746   while (u != NULL)
1747     {
1748       if (u->unit_number > min_unit)
1749         {
1750           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1751           if (r != NULL)
1752             return r;
1753         }
1754       if (u->unit_number >= min_unit)
1755         {
1756           if (__gthread_mutex_trylock (&u->lock))
1757             return u;
1758           if (u->s)
1759             sflush (u->s);
1760           __gthread_mutex_unlock (&u->lock);
1761         }
1762       u = u->right;
1763     }
1764   return NULL;
1765 }
1766
1767 void
1768 flush_all_units (void)
1769 {
1770   gfc_unit *u;
1771   int min_unit = 0;
1772
1773   __gthread_mutex_lock (&unit_lock);
1774   do
1775     {
1776       u = flush_all_units_1 (unit_root, min_unit);
1777       if (u != NULL)
1778         inc_waiting_locked (u);
1779       __gthread_mutex_unlock (&unit_lock);
1780       if (u == NULL)
1781         return;
1782
1783       __gthread_mutex_lock (&u->lock);
1784
1785       min_unit = u->unit_number + 1;
1786
1787       if (u->closed == 0)
1788         {
1789           sflush (u->s);
1790           __gthread_mutex_lock (&unit_lock);
1791           __gthread_mutex_unlock (&u->lock);
1792           (void) predec_waiting_locked (u);
1793         }
1794       else
1795         {
1796           __gthread_mutex_lock (&unit_lock);
1797           __gthread_mutex_unlock (&u->lock);
1798           if (predec_waiting_locked (u) == 0)
1799             free (u);
1800         }
1801     }
1802   while (1);
1803 }
1804
1805
1806 /* Unlock the unit if necessary, based on SHARE flags.  */
1807
1808 int
1809 close_share (gfc_unit *u __attribute__ ((unused)))
1810 {
1811   int r = 0;
1812 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1813   unix_stream *s = (unix_stream *) u->s;
1814   int fd = s->fd;
1815   struct flock f;
1816
1817   switch (u->flags.share)
1818   {
1819     case SHARE_DENYRW:
1820     case SHARE_DENYNONE:
1821       if (fd != STDOUT_FILENO && fd != STDERR_FILENO && fd != STDIN_FILENO)
1822         {
1823           f.l_start = 0;
1824           f.l_len = 0;
1825           f.l_whence = SEEK_SET;
1826           f.l_type = F_UNLCK;
1827           r = fcntl (fd, F_SETLK, &f);
1828         }
1829       break;
1830     case SHARE_UNSPECIFIED:
1831     default:
1832       break;
1833   }
1834
1835 #endif
1836   return r;
1837 }
1838
1839
1840 /* file_exists()-- Returns nonzero if the current filename exists on
1841  * the system */
1842
1843 int
1844 file_exists (const char *file, gfc_charlen_type file_len)
1845 {
1846   char *path = fc_strdup (file, file_len);
1847   int res = !(access (path, F_OK));
1848   free (path);
1849   return res;
1850 }
1851
1852
1853 /* file_size()-- Returns the size of the file.  */
1854
1855 GFC_IO_INT
1856 file_size (const char *file, gfc_charlen_type file_len)
1857 {
1858   char *path = fc_strdup (file, file_len);
1859   struct stat statbuf;
1860   int err;
1861   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1862   free (path);
1863   if (err == -1)
1864     return -1;
1865   return (GFC_IO_INT) statbuf.st_size;
1866 }
1867
1868 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1869
1870 /* inquire_sequential()-- Given a fortran string, determine if the
1871  * file is suitable for sequential access.  Returns a C-style
1872  * string. */
1873
1874 const char *
1875 inquire_sequential (const char *string, int len)
1876 {
1877   struct stat statbuf;
1878
1879   if (string == NULL)
1880     return unknown;
1881
1882   char *path = fc_strdup (string, len);
1883   int err;
1884   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1885   free (path);
1886   if (err == -1)
1887     return unknown;
1888
1889   if (S_ISREG (statbuf.st_mode) ||
1890       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1891     return unknown;
1892
1893   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1894     return no;
1895
1896   return unknown;
1897 }
1898
1899
1900 /* inquire_direct()-- Given a fortran string, determine if the file is
1901  * suitable for direct access.  Returns a C-style string. */
1902
1903 const char *
1904 inquire_direct (const char *string, int len)
1905 {
1906   struct stat statbuf;
1907
1908   if (string == NULL)
1909     return unknown;
1910
1911   char *path = fc_strdup (string, len);
1912   int err;
1913   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1914   free (path);
1915   if (err == -1)
1916     return unknown;
1917
1918   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1919     return unknown;
1920
1921   if (S_ISDIR (statbuf.st_mode) ||
1922       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1923     return no;
1924
1925   return unknown;
1926 }
1927
1928
1929 /* inquire_formatted()-- Given a fortran string, determine if the file
1930  * is suitable for formatted form.  Returns a C-style string. */
1931
1932 const char *
1933 inquire_formatted (const char *string, int len)
1934 {
1935   struct stat statbuf;
1936
1937   if (string == NULL)
1938     return unknown;
1939
1940   char *path = fc_strdup (string, len);
1941   int err;
1942   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1943   free (path);
1944   if (err == -1)
1945     return unknown;
1946
1947   if (S_ISREG (statbuf.st_mode) ||
1948       S_ISBLK (statbuf.st_mode) ||
1949       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1950     return unknown;
1951
1952   if (S_ISDIR (statbuf.st_mode))
1953     return no;
1954
1955   return unknown;
1956 }
1957
1958
1959 /* inquire_unformatted()-- Given a fortran string, determine if the file
1960  * is suitable for unformatted form.  Returns a C-style string. */
1961
1962 const char *
1963 inquire_unformatted (const char *string, int len)
1964 {
1965   return inquire_formatted (string, len);
1966 }
1967
1968
1969 /* inquire_access()-- Given a fortran string, determine if the file is
1970  * suitable for access. */
1971
1972 static const char *
1973 inquire_access (const char *string, int len, int mode)
1974 {
1975   if (string == NULL)
1976     return no;
1977   char *path = fc_strdup (string, len);
1978   int res = access (path, mode);
1979   free (path);
1980   if (res == -1)
1981     return no;
1982
1983   return yes;
1984 }
1985
1986
1987 /* inquire_read()-- Given a fortran string, determine if the file is
1988  * suitable for READ access. */
1989
1990 const char *
1991 inquire_read (const char *string, int len)
1992 {
1993   return inquire_access (string, len, R_OK);
1994 }
1995
1996
1997 /* inquire_write()-- Given a fortran string, determine if the file is
1998  * suitable for READ access. */
1999
2000 const char *
2001 inquire_write (const char *string, int len)
2002 {
2003   return inquire_access (string, len, W_OK);
2004 }
2005
2006
2007 /* inquire_readwrite()-- Given a fortran string, determine if the file is
2008  * suitable for read and write access. */
2009
2010 const char *
2011 inquire_readwrite (const char *string, int len)
2012 {
2013   return inquire_access (string, len, R_OK | W_OK);
2014 }
2015
2016
2017 int
2018 stream_isatty (stream *s)
2019 {
2020   return isatty (((unix_stream *) s)->fd);
2021 }
2022
2023 int
2024 stream_ttyname (stream *s  __attribute__ ((unused)),
2025                 char * buf  __attribute__ ((unused)),
2026                 size_t buflen  __attribute__ ((unused)))
2027 {
2028 #ifdef HAVE_TTYNAME_R
2029   return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
2030 #elif defined HAVE_TTYNAME
2031   char *p;
2032   size_t plen;
2033   p = ttyname (((unix_stream *) s)->fd);
2034   if (!p)
2035     return errno;
2036   plen = strlen (p);
2037   if (buflen < plen)
2038     plen = buflen;
2039   memcpy (buf, p, plen);
2040   return 0;
2041 #else
2042   return ENOSYS;
2043 #endif
2044 }
2045
2046
2047
2048
2049 /* How files are stored:  This is an operating-system specific issue,
2050    and therefore belongs here.  There are three cases to consider.
2051
2052    Direct Access:
2053       Records are written as block of bytes corresponding to the record
2054       length of the file.  This goes for both formatted and unformatted
2055       records.  Positioning is done explicitly for each data transfer,
2056       so positioning is not much of an issue.
2057
2058    Sequential Formatted:
2059       Records are separated by newline characters.  The newline character
2060       is prohibited from appearing in a string.  If it does, this will be
2061       messed up on the next read.  End of file is also the end of a record.
2062
2063    Sequential Unformatted:
2064       In this case, we are merely copying bytes to and from main storage,
2065       yet we need to keep track of varying record lengths.  We adopt
2066       the solution used by f2c.  Each record contains a pair of length
2067       markers:
2068
2069         Length of record n in bytes
2070         Data of record n
2071         Length of record n in bytes
2072
2073         Length of record n+1 in bytes
2074         Data of record n+1
2075         Length of record n+1 in bytes
2076
2077      The length is stored at the end of a record to allow backspacing to the
2078      previous record.  Between data transfer statements, the file pointer
2079      is left pointing to the first length of the current record.
2080
2081      ENDFILE records are never explicitly stored.
2082
2083 */