libgfortran/io/unix.c

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