libgfortran/io/unix.c

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