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