libgfortran/io/unix.c

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