libgfortran/io/unix.c

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