libgfortran/io/unix.c

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