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