libgfortran/io/unix.c

   1 /* Copyright (C) 2002-2024 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   free (s);
1032   return 0;
1033 }
1034
1035 static const struct stream_vtable mem_vtable = {
1036   .read = (void *) mem_read,
1037   .write = (void *) mem_write,
1038   .seek = (void *) mem_seek,
1039   .tell = (void *) mem_tell,
1040   /* buf_size is not a typo, we just reuse an identical
1041      implementation.  */
1042   .size = (void *) buf_size,
1043   .trunc = (void *) mem_truncate,
1044   .close = (void *) mem_close,
1045   .flush = (void *) mem_flush,
1046   .markeor = (void *) raw_markeor
1047 };
1048
1049 static const struct stream_vtable mem4_vtable = {
1050   .read = (void *) mem_read4,
1051   .write = (void *) mem_write4,
1052   .seek = (void *) mem_seek,
1053   .tell = (void *) mem_tell,
1054   /* buf_size is not a typo, we just reuse an identical
1055      implementation.  */
1056   .size = (void *) buf_size,
1057   .trunc = (void *) mem_truncate,
1058   .close = (void *) mem_close,
1059   .flush = (void *) mem_flush,
1060   .markeor = (void *) raw_markeor
1061 };
1062
1063 /*********************************************************************
1064   Public functions -- A reimplementation of this module needs to
1065   define functional equivalents of the following.
1066 *********************************************************************/
1067
1068 /* open_internal()-- Returns a stream structure from a character(kind=1)
1069    internal file */
1070
1071 stream *
1072 open_internal (char *base, size_t length, gfc_offset offset)
1073 {
1074   unix_stream *s;
1075
1076   s = xcalloc (1, sizeof (unix_stream));
1077
1078   s->buffer = base;
1079   s->buffer_offset = offset;
1080
1081   s->active = s->file_length = length;
1082
1083   s->st.vptr = &mem_vtable;
1084
1085   return (stream *) s;
1086 }
1087
1088 /* open_internal4()-- Returns a stream structure from a character(kind=4)
1089    internal file */
1090
1091 stream *
1092 open_internal4 (char *base, size_t length, gfc_offset offset)
1093 {
1094   unix_stream *s;
1095
1096   s = xcalloc (1, sizeof (unix_stream));
1097
1098   s->buffer = base;
1099   s->buffer_offset = offset;
1100
1101   s->active = s->file_length = length * sizeof (gfc_char4_t);
1102
1103   s->st.vptr = &mem4_vtable;
1104
1105   return (stream *)s;
1106 }
1107
1108
1109 /* fd_to_stream()-- Given an open file descriptor, build a stream
1110    around it. */
1111
1112 static stream *
1113 fd_to_stream (int fd, bool unformatted)
1114 {
1115   struct stat statbuf;
1116   unix_stream *s;
1117
1118   s = xcalloc (1, sizeof (unix_stream));
1119
1120   s->fd = fd;
1121
1122   /* Get the current length of the file. */
1123
1124   if (TEMP_FAILURE_RETRY (fstat (fd, &statbuf)) == -1)
1125     {
1126       s->st_dev = s->st_ino = -1;
1127       s->file_length = 0;
1128       if (errno == EBADF)
1129         s->fd = -1;
1130       raw_init (s);
1131       return (stream *) s;
1132     }
1133
1134   s->st_dev = statbuf.st_dev;
1135   s->st_ino = statbuf.st_ino;
1136   s->file_length = statbuf.st_size;
1137
1138   /* Only use buffered IO for regular files.  */
1139   if (S_ISREG (statbuf.st_mode)
1140       && !options.all_unbuffered
1141       && !(options.unbuffered_preconnected &&
1142            (s->fd == STDIN_FILENO
1143             || s->fd == STDOUT_FILENO
1144             || s->fd == STDERR_FILENO)))
1145     buf_init (s, unformatted);
1146   else
1147     {
1148       if (unformatted)
1149         {
1150           s->unbuffered = true;
1151           buf_init (s, unformatted);
1152         }
1153       else
1154         raw_init (s);
1155     }
1156
1157   return (stream *) s;
1158 }
1159
1160
1161 /* Given the Fortran unit number, convert it to a C file descriptor.  */
1162
1163 int
1164 unit_to_fd (int unit)
1165 {
1166   gfc_unit *us;
1167   int fd;
1168
1169   us = find_unit (unit);
1170   if (us == NULL)
1171     return -1;
1172
1173   fd = ((unix_stream *) us->s)->fd;
1174   unlock_unit (us);
1175   return fd;
1176 }
1177
1178
1179 /* Set the close-on-exec flag for an existing fd, if the system
1180    supports such.  */
1181
1182 static void __attribute__ ((unused))
1183 set_close_on_exec (int fd __attribute__ ((unused)))
1184 {
1185   /* Mingw does not define F_SETFD.  */
1186 #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1187   if (fd >= 0)
1188     fcntl(fd, F_SETFD, FD_CLOEXEC);
1189 #endif
1190 }
1191
1192
1193 /* Helper function for tempfile(). Tries to open a temporary file in
1194    the directory specified by tempdir. If successful, the file name is
1195    stored in fname and the descriptor returned. Returns -1 on
1196    failure.  */
1197
1198 static int
1199 tempfile_open (const char *tempdir, char **fname)
1200 {
1201   int fd;
1202   const char *slash = "/";
1203 #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1204   mode_t mode_mask;
1205 #endif
1206
1207   if (!tempdir)
1208     return -1;
1209
1210   /* Check for the special case that tempdir ends with a slash or
1211      backslash.  */
1212   size_t tempdirlen = strlen (tempdir);
1213   if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1214 #ifdef __MINGW32__
1215       || tempdir[tempdirlen - 1] == '\\'
1216 #endif
1217      )
1218     slash = "";
1219
1220   /* Take care that the template is longer in the mktemp() branch.  */
1221   char *template = xmalloc (tempdirlen + 23);
1222
1223 #ifdef HAVE_MKSTEMP
1224   snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1225             tempdir, slash);
1226
1227 #ifdef HAVE_UMASK
1228   /* Temporarily set the umask such that the file has 0600 permissions.  */
1229   mode_mask = umask (S_IXUSR | S_IRWXG | S_IRWXO);
1230 #endif
1231
1232 #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1233   TEMP_FAILURE_RETRY (fd = mkostemp (template, O_CLOEXEC));
1234 #else
1235   TEMP_FAILURE_RETRY (fd = mkstemp (template));
1236   set_close_on_exec (fd);
1237 #endif
1238
1239 #ifdef HAVE_UMASK
1240   (void) umask (mode_mask);
1241 #endif
1242
1243 #else /* HAVE_MKSTEMP */
1244   fd = -1;
1245   int count = 0;
1246   size_t slashlen = strlen (slash);
1247   int flags = O_RDWR | O_CREAT | O_EXCL;
1248 #if defined(HAVE_CRLF) && defined(O_BINARY)
1249   flags |= O_BINARY;
1250 #endif
1251 #ifdef O_CLOEXEC
1252   flags |= O_CLOEXEC;
1253 #endif
1254   do
1255     {
1256       snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1257                 tempdir, slash);
1258       if (count > 0)
1259         {
1260           int c = count;
1261           template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1262           c /= 26;
1263           template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1264           c /= 26;
1265           template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1266           if (c >= 26)
1267             break;
1268         }
1269
1270       if (!mktemp (template))
1271       {
1272         errno = EEXIST;
1273         count++;
1274         continue;
1275       }
1276
1277       TEMP_FAILURE_RETRY (fd = open (template, flags, S_IRUSR | S_IWUSR));
1278     }
1279   while (fd == -1 && errno == EEXIST);
1280 #ifndef O_CLOEXEC
1281   set_close_on_exec (fd);
1282 #endif
1283 #endif /* HAVE_MKSTEMP */
1284
1285   *fname = template;
1286   return fd;
1287 }
1288
1289
1290 /* tempfile()-- Generate a temporary filename for a scratch file and
1291    open it.  mkstemp() opens the file for reading and writing, but the
1292    library mode prevents anything that is not allowed.  The descriptor
1293    is returned, which is -1 on error.  The template is pointed to by
1294    opp->file, which is copied into the unit structure
1295    and freed later. */
1296
1297 static int
1298 tempfile (st_parameter_open *opp)
1299 {
1300   const char *tempdir;
1301   char *fname;
1302   int fd = -1;
1303
1304   tempdir = secure_getenv ("TMPDIR");
1305   fd = tempfile_open (tempdir, &fname);
1306 #ifdef __MINGW32__
1307   if (fd == -1)
1308     {
1309       char buffer[MAX_PATH + 1];
1310       DWORD ret;
1311       ret = GetTempPath (MAX_PATH, buffer);
1312       /* If we are not able to get a temp-directory, we use
1313          current directory.  */
1314       if (ret > MAX_PATH || !ret)
1315         buffer[0] = 0;
1316       else
1317         buffer[ret] = 0;
1318       tempdir = strdup (buffer);
1319       fd = tempfile_open (tempdir, &fname);
1320     }
1321 #elif defined(__CYGWIN__)
1322   if (fd == -1)
1323     {
1324       tempdir = secure_getenv ("TMP");
1325       fd = tempfile_open (tempdir, &fname);
1326     }
1327   if (fd == -1)
1328     {
1329       tempdir = secure_getenv ("TEMP");
1330       fd = tempfile_open (tempdir, &fname);
1331     }
1332 #endif
1333   if (fd == -1)
1334     fd = tempfile_open (P_tmpdir, &fname);
1335
1336   opp->file = fname;
1337   opp->file_len = strlen (fname);       /* Don't include trailing nul */
1338
1339   return fd;
1340 }
1341
1342
1343 /* regular_file2()-- Open a regular file.
1344    Change flags->action if it is ACTION_UNSPECIFIED on entry,
1345    unless an error occurs.
1346    Returns the descriptor, which is less than zero on error. */
1347
1348 static int
1349 regular_file2 (const char *path, st_parameter_open *opp, unit_flags *flags)
1350 {
1351   int mode;
1352   int rwflag;
1353   int crflag, crflag2;
1354   int fd;
1355
1356 #ifdef __CYGWIN__
1357   if (opp->file_len == 7)
1358     {
1359       if (strncmp (path, "CONOUT$", 7) == 0
1360           || strncmp (path, "CONERR$", 7) == 0)
1361         {
1362           fd = open ("/dev/conout", O_WRONLY);
1363           flags->action = ACTION_WRITE;
1364           return fd;
1365         }
1366     }
1367
1368   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1369     {
1370       fd = open ("/dev/conin", O_RDONLY);
1371       flags->action = ACTION_READ;
1372       return fd;
1373     }
1374 #endif
1375
1376
1377 #ifdef __MINGW32__
1378   if (opp->file_len == 7)
1379     {
1380       if (strncmp (path, "CONOUT$", 7) == 0
1381           || strncmp (path, "CONERR$", 7) == 0)
1382         {
1383           fd = open ("CONOUT$", O_WRONLY);
1384           flags->action = ACTION_WRITE;
1385           return fd;
1386         }
1387     }
1388
1389   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1390     {
1391       fd = open ("CONIN$", O_RDONLY);
1392       flags->action = ACTION_READ;
1393       return fd;
1394     }
1395 #endif
1396
1397   switch (flags->action)
1398     {
1399     case ACTION_READ:
1400       rwflag = O_RDONLY;
1401       break;
1402
1403     case ACTION_WRITE:
1404       rwflag = O_WRONLY;
1405       break;
1406
1407     case ACTION_READWRITE:
1408     case ACTION_UNSPECIFIED:
1409       rwflag = O_RDWR;
1410       break;
1411
1412     default:
1413       internal_error (&opp->common, "regular_file(): Bad action");
1414     }
1415
1416   switch (flags->status)
1417     {
1418     case STATUS_NEW:
1419       crflag = O_CREAT | O_EXCL;
1420       break;
1421
1422     case STATUS_OLD:            /* open will fail if the file does not exist*/
1423       crflag = 0;
1424       break;
1425
1426     case STATUS_UNKNOWN:
1427       if (rwflag == O_RDONLY)
1428         crflag = 0;
1429       else
1430         crflag = O_CREAT;
1431       break;
1432
1433     case STATUS_REPLACE:
1434       crflag = O_CREAT | O_TRUNC;
1435       break;
1436
1437     default:
1438       /* Note: STATUS_SCRATCH is handled by tempfile () and should
1439          never be seen here.  */
1440       internal_error (&opp->common, "regular_file(): Bad status");
1441     }
1442
1443   /* rwflag |= O_LARGEFILE; */
1444
1445 #if defined(HAVE_CRLF) && defined(O_BINARY)
1446   crflag |= O_BINARY;
1447 #endif
1448
1449 #ifdef O_CLOEXEC
1450   crflag |= O_CLOEXEC;
1451 #endif
1452
1453   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1454   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1455   if (flags->action != ACTION_UNSPECIFIED)
1456     return fd;
1457
1458   if (fd >= 0)
1459     {
1460       flags->action = ACTION_READWRITE;
1461       return fd;
1462     }
1463   if (errno != EACCES && errno != EPERM && errno != EROFS)
1464      return fd;
1465
1466   /* retry for read-only access */
1467   rwflag = O_RDONLY;
1468   if (flags->status == STATUS_UNKNOWN)
1469     crflag2 = crflag & ~(O_CREAT);
1470   else
1471     crflag2 = crflag;
1472   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag2, mode));
1473   if (fd >=0)
1474     {
1475       flags->action = ACTION_READ;
1476       return fd;                /* success */
1477     }
1478
1479   if (errno != EACCES && errno != EPERM && errno != ENOENT)
1480     return fd;                  /* failure */
1481
1482   /* retry for write-only access */
1483   rwflag = O_WRONLY;
1484   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1485   if (fd >=0)
1486     {
1487       flags->action = ACTION_WRITE;
1488       return fd;                /* success */
1489     }
1490   return fd;                    /* failure */
1491 }
1492
1493
1494 /* Lock the file, if necessary, based on SHARE flags.  */
1495
1496 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1497 static int
1498 open_share (st_parameter_open *opp, int fd, unit_flags *flags)
1499 {
1500   int r = 0;
1501   struct flock f;
1502   if (fd == STDOUT_FILENO || fd == STDERR_FILENO || fd == STDIN_FILENO)
1503     return 0;
1504
1505   f.l_start = 0;
1506   f.l_len = 0;
1507   f.l_whence = SEEK_SET;
1508
1509   switch (flags->share)
1510   {
1511     case SHARE_DENYNONE:
1512       f.l_type = F_RDLCK;
1513       r = fcntl (fd, F_SETLK, &f);
1514       break;
1515     case SHARE_DENYRW:
1516       /* Must be writable to hold write lock.  */
1517       if (flags->action == ACTION_READ)
1518         {
1519           generate_error (&opp->common, LIBERROR_BAD_ACTION,
1520               "Cannot set write lock on file opened for READ");
1521           return -1;
1522         }
1523       f.l_type = F_WRLCK;
1524       r = fcntl (fd, F_SETLK, &f);
1525       break;
1526     case SHARE_UNSPECIFIED:
1527     default:
1528       break;
1529   }
1530
1531   return r;
1532 }
1533 #else
1534 static int
1535 open_share (st_parameter_open *opp __attribute__ ((unused)),
1536     int fd __attribute__ ((unused)),
1537     unit_flags *flags __attribute__ ((unused)))
1538 {
1539   return 0;
1540 }
1541 #endif /* defined(HAVE_FCNTL) ... */
1542
1543
1544 /* Wrapper around regular_file2, to make sure we free the path after
1545    we're done.  */
1546
1547 static int
1548 regular_file (st_parameter_open *opp, unit_flags *flags)
1549 {
1550   char *path = fc_strdup (opp->file, opp->file_len);
1551   int fd = regular_file2 (path, opp, flags);
1552   free (path);
1553   return fd;
1554 }
1555
1556 /* open_external()-- Open an external file, unix specific version.
1557    Change flags->action if it is ACTION_UNSPECIFIED on entry.
1558    Returns NULL on operating system error. */
1559
1560 stream *
1561 open_external (st_parameter_open *opp, unit_flags *flags)
1562 {
1563   int fd;
1564
1565   if (flags->status == STATUS_SCRATCH)
1566     {
1567       fd = tempfile (opp);
1568       if (flags->action == ACTION_UNSPECIFIED)
1569         flags->action = flags->readonly ? ACTION_READ : ACTION_READWRITE;
1570
1571 #if HAVE_UNLINK_OPEN_FILE
1572       /* We can unlink scratch files now and it will go away when closed. */
1573       if (fd >= 0)
1574         unlink (opp->file);
1575 #endif
1576     }
1577   else
1578     {
1579       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1580          if it succeeds */
1581       fd = regular_file (opp, flags);
1582 #ifndef O_CLOEXEC
1583       set_close_on_exec (fd);
1584 #endif
1585     }
1586
1587   if (fd < 0)
1588     return NULL;
1589   fd = fix_fd (fd);
1590
1591   if (open_share (opp, fd, flags) < 0)
1592     return NULL;
1593
1594   return fd_to_stream (fd, flags->form == FORM_UNFORMATTED);
1595 }
1596
1597
1598 /* input_stream()-- Return a stream pointer to the default input stream.
1599    Called on initialization. */
1600
1601 stream *
1602 input_stream (void)
1603 {
1604   return fd_to_stream (STDIN_FILENO, false);
1605 }
1606
1607
1608 /* output_stream()-- Return a stream pointer to the default output stream.
1609    Called on initialization. */
1610
1611 stream *
1612 output_stream (void)
1613 {
1614   stream *s;
1615
1616 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1617   setmode (STDOUT_FILENO, O_BINARY);
1618 #endif
1619
1620   s = fd_to_stream (STDOUT_FILENO, false);
1621   return s;
1622 }
1623
1624
1625 /* error_stream()-- Return a stream pointer to the default error stream.
1626    Called on initialization. */
1627
1628 stream *
1629 error_stream (void)
1630 {
1631   stream *s;
1632
1633 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1634   setmode (STDERR_FILENO, O_BINARY);
1635 #endif
1636
1637   s = fd_to_stream (STDERR_FILENO, false);
1638   return s;
1639 }
1640
1641
1642 /* compare_file_filename()-- Given an open stream and a fortran string
1643    that is a filename, figure out if the file is the same as the
1644    filename. */
1645
1646 int
1647 compare_file_filename (gfc_unit *u, const char *name, gfc_charlen_type len)
1648 {
1649   struct stat st;
1650   int ret;
1651 #ifdef HAVE_WORKING_STAT
1652   unix_stream *s;
1653 #else
1654 # ifdef __MINGW32__
1655   uint64_t id1, id2;
1656 # endif
1657 #endif
1658
1659   char *path = fc_strdup (name, len);
1660
1661   /* If the filename doesn't exist, then there is no match with the
1662      existing file. */
1663
1664   if (TEMP_FAILURE_RETRY (stat (path, &st)) < 0)
1665     {
1666       ret = 0;
1667       goto done;
1668     }
1669
1670 #ifdef HAVE_WORKING_STAT
1671   s = (unix_stream *) (u->s);
1672   ret = (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1673   goto done;
1674 #else
1675
1676 # ifdef __MINGW32__
1677   /* We try to match files by a unique ID.  On some filesystems (network
1678      fs and FAT), we can't generate this unique ID, and will simply compare
1679      filenames.  */
1680   id1 = id_from_path (path);
1681   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1682   if (id1 || id2)
1683     {
1684       ret = (id1 == id2);
1685       goto done;
1686     }
1687 # endif
1688   if (u->filename)
1689     ret = (strcmp(path, u->filename) == 0);
1690   else
1691     ret = 0;
1692 #endif
1693  done:
1694   free (path);
1695   return ret;
1696 }
1697
1698
1699 #ifdef HAVE_WORKING_STAT
1700 # define FIND_FILE0_DECL struct stat *st
1701 # define FIND_FILE0_ARGS st
1702 #else
1703 # define FIND_FILE0_DECL uint64_t id, const char *path
1704 # define FIND_FILE0_ARGS id, path
1705 #endif
1706
1707 /* find_file0()-- Recursive work function for find_file() */
1708
1709 static gfc_unit *
1710 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1711 {
1712   gfc_unit *v;
1713 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1714   uint64_t id1;
1715 #endif
1716
1717   if (u == NULL)
1718     return NULL;
1719
1720 #ifdef HAVE_WORKING_STAT
1721   if (u->s != NULL)
1722     {
1723       unix_stream *s = (unix_stream *) (u->s);
1724       if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1725         return u;
1726     }
1727 #else
1728 # ifdef __MINGW32__
1729   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1730     {
1731       if (id == id1)
1732         return u;
1733     }
1734   else
1735 # endif
1736     if (u->filename && strcmp (u->filename, path) == 0)
1737       return u;
1738 #endif
1739
1740   v = find_file0 (u->left, FIND_FILE0_ARGS);
1741   if (v != NULL)
1742     return v;
1743
1744   v = find_file0 (u->right, FIND_FILE0_ARGS);
1745   if (v != NULL)
1746     return v;
1747
1748   return NULL;
1749 }
1750
1751
1752 /* find_file()-- Take the current filename and see if there is a unit
1753    that has the file already open.  Returns a pointer to the unit if so. */
1754
1755 gfc_unit *
1756 find_file (const char *file, gfc_charlen_type file_len)
1757 {
1758   struct stat st[1];
1759   gfc_unit *u;
1760 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1761   uint64_t id = 0ULL;
1762 #endif
1763
1764   char *path = fc_strdup (file, file_len);
1765
1766   if (TEMP_FAILURE_RETRY (stat (path, &st[0])) < 0)
1767     {
1768       u = NULL;
1769       goto done;
1770     }
1771
1772 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1773   id = id_from_path (path);
1774 #endif
1775
1776   RDLOCK (&unit_rwlock);
1777 retry:
1778   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1779   if (u != NULL)
1780     {
1781       /* Fast path.  */
1782       if (! __gthread_mutex_trylock (&u->lock))
1783         {
1784           /* assert (u->closed == 0); */
1785           RWUNLOCK (&unit_rwlock);
1786           goto done;
1787         }
1788
1789       inc_waiting_locked (u);
1790     }
1791   RWUNLOCK (&unit_rwlock);
1792   if (u != NULL)
1793     {
1794       LOCK (&u->lock);
1795       if (u->closed)
1796         {
1797           RDLOCK (&unit_rwlock);
1798           UNLOCK (&u->lock);
1799           if (predec_waiting_locked (u) == 0)
1800             free (u);
1801           goto retry;
1802         }
1803
1804       dec_waiting_unlocked (u);
1805     }
1806  done:
1807   free (path);
1808   return u;
1809 }
1810
1811 static gfc_unit *
1812 flush_all_units_1 (gfc_unit *u, int min_unit)
1813 {
1814   while (u != NULL)
1815     {
1816       if (u->unit_number > min_unit)
1817         {
1818           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1819           if (r != NULL)
1820             return r;
1821         }
1822       if (u->unit_number >= min_unit)
1823         {
1824           if (__gthread_mutex_trylock (&u->lock))
1825             return u;
1826           if (u->s)
1827             sflush (u->s);
1828           UNLOCK (&u->lock);
1829         }
1830       u = u->right;
1831     }
1832   return NULL;
1833 }
1834
1835 void
1836 flush_all_units (void)
1837 {
1838   gfc_unit *u;
1839   int min_unit = 0;
1840
1841   WRLOCK (&unit_rwlock);
1842   do
1843     {
1844       u = flush_all_units_1 (unit_root, min_unit);
1845       if (u != NULL)
1846         inc_waiting_locked (u);
1847       RWUNLOCK (&unit_rwlock);
1848       if (u == NULL)
1849         return;
1850
1851       LOCK (&u->lock);
1852
1853       min_unit = u->unit_number + 1;
1854
1855       if (u->closed == 0)
1856         {
1857           sflush (u->s);
1858           WRLOCK (&unit_rwlock);
1859           UNLOCK (&u->lock);
1860           (void) predec_waiting_locked (u);
1861         }
1862       else
1863         {
1864           WRLOCK (&unit_rwlock);
1865           UNLOCK (&u->lock);
1866           if (predec_waiting_locked (u) == 0)
1867             free (u);
1868         }
1869     }
1870   while (1);
1871 }
1872
1873
1874 /* Unlock the unit if necessary, based on SHARE flags.  */
1875
1876 int
1877 close_share (gfc_unit *u __attribute__ ((unused)))
1878 {
1879   int r = 0;
1880 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1881   unix_stream *s = (unix_stream *) u->s;
1882   int fd = s->fd;
1883   struct flock f;
1884
1885   switch (u->flags.share)
1886   {
1887     case SHARE_DENYRW:
1888     case SHARE_DENYNONE:
1889       if (fd != STDOUT_FILENO && fd != STDERR_FILENO && fd != STDIN_FILENO)
1890         {
1891           f.l_start = 0;
1892           f.l_len = 0;
1893           f.l_whence = SEEK_SET;
1894           f.l_type = F_UNLCK;
1895           r = fcntl (fd, F_SETLK, &f);
1896         }
1897       break;
1898     case SHARE_UNSPECIFIED:
1899     default:
1900       break;
1901   }
1902
1903 #endif
1904   return r;
1905 }
1906
1907
1908 /* file_exists()-- Returns nonzero if the current filename exists on
1909    the system */
1910
1911 int
1912 file_exists (const char *file, gfc_charlen_type file_len)
1913 {
1914   char *path = fc_strdup (file, file_len);
1915   int res = !(access (path, F_OK));
1916   free (path);
1917   return res;
1918 }
1919
1920
1921 /* file_size()-- Returns the size of the file.  */
1922
1923 GFC_IO_INT
1924 file_size (const char *file, gfc_charlen_type file_len)
1925 {
1926   char *path = fc_strdup (file, file_len);
1927   struct stat statbuf;
1928   int err;
1929   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1930   free (path);
1931   if (err == -1)
1932     return -1;
1933   return (GFC_IO_INT) statbuf.st_size;
1934 }
1935
1936 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1937
1938 /* inquire_sequential()-- Given a fortran string, determine if the
1939    file is suitable for sequential access.  Returns a C-style
1940    string. */
1941
1942 const char *
1943 inquire_sequential (const char *string, gfc_charlen_type len)
1944 {
1945   struct stat statbuf;
1946
1947   if (string == NULL)
1948     return unknown;
1949
1950   char *path = fc_strdup (string, len);
1951   int err;
1952   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1953   free (path);
1954   if (err == -1)
1955     return unknown;
1956
1957   if (S_ISREG (statbuf.st_mode) ||
1958       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1959     return unknown;
1960
1961   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1962     return no;
1963
1964   return unknown;
1965 }
1966
1967
1968 /* inquire_direct()-- Given a fortran string, determine if the file is
1969    suitable for direct access.  Returns a C-style string. */
1970
1971 const char *
1972 inquire_direct (const char *string, gfc_charlen_type len)
1973 {
1974   struct stat statbuf;
1975
1976   if (string == NULL)
1977     return unknown;
1978
1979   char *path = fc_strdup (string, len);
1980   int err;
1981   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1982   free (path);
1983   if (err == -1)
1984     return unknown;
1985
1986   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1987     return unknown;
1988
1989   if (S_ISDIR (statbuf.st_mode) ||
1990       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1991     return no;
1992
1993   return unknown;
1994 }
1995
1996
1997 /* inquire_formatted()-- Given a fortran string, determine if the file
1998    is suitable for formatted form.  Returns a C-style string. */
1999
2000 const char *
2001 inquire_formatted (const char *string, gfc_charlen_type len)
2002 {
2003   struct stat statbuf;
2004
2005   if (string == NULL)
2006     return unknown;
2007
2008   char *path = fc_strdup (string, len);
2009   int err;
2010   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
2011   free (path);
2012   if (err == -1)
2013     return unknown;
2014
2015   if (S_ISREG (statbuf.st_mode) ||
2016       S_ISBLK (statbuf.st_mode) ||
2017       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
2018     return unknown;
2019
2020   if (S_ISDIR (statbuf.st_mode))
2021     return no;
2022
2023   return unknown;
2024 }
2025
2026
2027 /* inquire_unformatted()-- Given a fortran string, determine if the file
2028    is suitable for unformatted form.  Returns a C-style string. */
2029
2030 const char *
2031 inquire_unformatted (const char *string, gfc_charlen_type len)
2032 {
2033   return inquire_formatted (string, len);
2034 }
2035
2036
2037 /* inquire_access()-- Given a fortran string, determine if the file is
2038    suitable for access. */
2039
2040 static const char *
2041 inquire_access (const char *string, gfc_charlen_type len, int mode)
2042 {
2043   if (string == NULL)
2044     return no;
2045   char *path = fc_strdup (string, len);
2046   int res = access (path, mode);
2047   free (path);
2048   if (res == -1)
2049     return no;
2050
2051   return yes;
2052 }
2053
2054
2055 /* inquire_read()-- Given a fortran string, determine if the file is
2056    suitable for READ access. */
2057
2058 const char *
2059 inquire_read (const char *string, gfc_charlen_type len)
2060 {
2061   return inquire_access (string, len, R_OK);
2062 }
2063
2064
2065 /* inquire_write()-- Given a fortran string, determine if the file is
2066    suitable for READ access. */
2067
2068 const char *
2069 inquire_write (const char *string, gfc_charlen_type len)
2070 {
2071   return inquire_access (string, len, W_OK);
2072 }
2073
2074
2075 /* inquire_readwrite()-- Given a fortran string, determine if the file is
2076    suitable for read and write access. */
2077
2078 const char *
2079 inquire_readwrite (const char *string, gfc_charlen_type len)
2080 {
2081   return inquire_access (string, len, R_OK | W_OK);
2082 }
2083
2084
2085 int
2086 stream_isatty (stream *s)
2087 {
2088   return isatty (((unix_stream *) s)->fd);
2089 }
2090
2091 int
2092 stream_ttyname (stream *s  __attribute__ ((unused)),
2093                 char *buf  __attribute__ ((unused)),
2094                 size_t buflen  __attribute__ ((unused)))
2095 {
2096 #ifdef HAVE_TTYNAME_R
2097   return ttyname_r (((unix_stream *)s)->fd, buf, buflen);
2098 #elif defined HAVE_TTYNAME
2099   char *p;
2100   size_t plen;
2101   p = ttyname (((unix_stream *)s)->fd);
2102   if (!p)
2103     return errno;
2104   plen = strlen (p);
2105   if (buflen < plen)
2106     plen = buflen;
2107   memcpy (buf, p, plen);
2108   return 0;
2109 #else
2110   return ENOSYS;
2111 #endif
2112 }
2113
2114
2115
2116
2117 /* How files are stored:  This is an operating-system specific issue,
2118    and therefore belongs here.  There are three cases to consider.
2119
2120    Direct Access:
2121       Records are written as block of bytes corresponding to the record
2122       length of the file.  This goes for both formatted and unformatted
2123       records.  Positioning is done explicitly for each data transfer,
2124       so positioning is not much of an issue.
2125
2126    Sequential Formatted:
2127       Records are separated by newline characters.  The newline character
2128       is prohibited from appearing in a string.  If it does, this will be
2129       messed up on the next read.  End of file is also the end of a record.
2130
2131    Sequential Unformatted:
2132       In this case, we are merely copying bytes to and from main storage,
2133       yet we need to keep track of varying record lengths.  We adopt
2134       the solution used by f2c.  Each record contains a pair of length
2135       markers:
2136
2137         Length of record n in bytes
2138         Data of record n
2139         Length of record n in bytes
2140
2141         Length of record n+1 in bytes
2142         Data of record n+1
2143         Length of record n+1 in bytes
2144
2145      The length is stored at the end of a record to allow backspacing to the
2146      previous record.  Between data transfer statements, the file pointer
2147      is left pointing to the first length of the current record.
2148
2149      ENDFILE records are never explicitly stored.
2150
2151 */