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