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   ret = (strcmp(path, u->filename) == 0);
1529 #endif
1530  done:
1531   free (path);
1532   return ret;
1533 }
1534
1535
1536 #ifdef HAVE_WORKING_STAT
1537 # define FIND_FILE0_DECL struct stat *st
1538 # define FIND_FILE0_ARGS st
1539 #else
1540 # define FIND_FILE0_DECL uint64_t id, const char *path
1541 # define FIND_FILE0_ARGS id, path
1542 #endif
1543
1544 /* find_file0()-- Recursive work function for find_file() */
1545
1546 static gfc_unit *
1547 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1548 {
1549   gfc_unit *v;
1550 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1551   uint64_t id1;
1552 #endif
1553
1554   if (u == NULL)
1555     return NULL;
1556
1557 #ifdef HAVE_WORKING_STAT
1558   if (u->s != NULL)
1559     {
1560       unix_stream *s = (unix_stream *) (u->s);
1561       if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1562         return u;
1563     }
1564 #else
1565 # ifdef __MINGW32__
1566   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1567     {
1568       if (id == id1)
1569         return u;
1570     }
1571   else
1572 # endif
1573     if (strcmp (u->filename, path) == 0)
1574       return u;
1575 #endif
1576
1577   v = find_file0 (u->left, FIND_FILE0_ARGS);
1578   if (v != NULL)
1579     return v;
1580
1581   v = find_file0 (u->right, FIND_FILE0_ARGS);
1582   if (v != NULL)
1583     return v;
1584
1585   return NULL;
1586 }
1587
1588
1589 /* find_file()-- Take the current filename and see if there is a unit
1590  * that has the file already open.  Returns a pointer to the unit if so. */
1591
1592 gfc_unit *
1593 find_file (const char *file, gfc_charlen_type file_len)
1594 {
1595   struct stat st[1];
1596   gfc_unit *u;
1597 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1598   uint64_t id = 0ULL;
1599 #endif
1600
1601   char *path = fc_strdup (file, file_len);
1602
1603   if (stat (path, &st[0]) < 0)
1604     {
1605       u = NULL;
1606       goto done;
1607     }
1608
1609 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1610   id = id_from_path (path);
1611 #endif
1612
1613   __gthread_mutex_lock (&unit_lock);
1614 retry:
1615   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1616   if (u != NULL)
1617     {
1618       /* Fast path.  */
1619       if (! __gthread_mutex_trylock (&u->lock))
1620         {
1621           /* assert (u->closed == 0); */
1622           __gthread_mutex_unlock (&unit_lock);
1623           goto done;
1624         }
1625
1626       inc_waiting_locked (u);
1627     }
1628   __gthread_mutex_unlock (&unit_lock);
1629   if (u != NULL)
1630     {
1631       __gthread_mutex_lock (&u->lock);
1632       if (u->closed)
1633         {
1634           __gthread_mutex_lock (&unit_lock);
1635           __gthread_mutex_unlock (&u->lock);
1636           if (predec_waiting_locked (u) == 0)
1637             free (u);
1638           goto retry;
1639         }
1640
1641       dec_waiting_unlocked (u);
1642     }
1643  done:
1644   free (path);
1645   return u;
1646 }
1647
1648 static gfc_unit *
1649 flush_all_units_1 (gfc_unit *u, int min_unit)
1650 {
1651   while (u != NULL)
1652     {
1653       if (u->unit_number > min_unit)
1654         {
1655           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1656           if (r != NULL)
1657             return r;
1658         }
1659       if (u->unit_number >= min_unit)
1660         {
1661           if (__gthread_mutex_trylock (&u->lock))
1662             return u;
1663           if (u->s)
1664             sflush (u->s);
1665           __gthread_mutex_unlock (&u->lock);
1666         }
1667       u = u->right;
1668     }
1669   return NULL;
1670 }
1671
1672 void
1673 flush_all_units (void)
1674 {
1675   gfc_unit *u;
1676   int min_unit = 0;
1677
1678   __gthread_mutex_lock (&unit_lock);
1679   do
1680     {
1681       u = flush_all_units_1 (unit_root, min_unit);
1682       if (u != NULL)
1683         inc_waiting_locked (u);
1684       __gthread_mutex_unlock (&unit_lock);
1685       if (u == NULL)
1686         return;
1687
1688       __gthread_mutex_lock (&u->lock);
1689
1690       min_unit = u->unit_number + 1;
1691
1692       if (u->closed == 0)
1693         {
1694           sflush (u->s);
1695           __gthread_mutex_lock (&unit_lock);
1696           __gthread_mutex_unlock (&u->lock);
1697           (void) predec_waiting_locked (u);
1698         }
1699       else
1700         {
1701           __gthread_mutex_lock (&unit_lock);
1702           __gthread_mutex_unlock (&u->lock);
1703           if (predec_waiting_locked (u) == 0)
1704             free (u);
1705         }
1706     }
1707   while (1);
1708 }
1709
1710
1711 /* delete_file()-- Given a unit structure, delete the file associated
1712  * with the unit.  Returns nonzero if something went wrong. */
1713
1714 int
1715 delete_file (gfc_unit * u)
1716 {
1717   return unlink (u->filename);
1718 }
1719
1720
1721 /* file_exists()-- Returns nonzero if the current filename exists on
1722  * the system */
1723
1724 int
1725 file_exists (const char *file, gfc_charlen_type file_len)
1726 {
1727   char *path = fc_strdup (file, file_len);
1728   int res = !(access (path, F_OK));
1729   free (path);
1730   return res;
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 = fc_strdup (file, file_len);
1740   struct stat statbuf;
1741   int err = stat (path, &statbuf);
1742   free (path);
1743   if (err == -1)
1744     return -1;
1745   return (GFC_IO_INT) statbuf.st_size;
1746 }
1747
1748 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1749
1750 /* inquire_sequential()-- Given a fortran string, determine if the
1751  * file is suitable for sequential access.  Returns a C-style
1752  * string. */
1753
1754 const char *
1755 inquire_sequential (const char *string, int len)
1756 {
1757   struct stat statbuf;
1758
1759   if (string == NULL)
1760     return unknown;
1761
1762   char *path = fc_strdup (string, len);
1763   int err = stat (path, &statbuf);
1764   free (path);
1765   if (err == -1)
1766     return unknown;
1767
1768   if (S_ISREG (statbuf.st_mode) ||
1769       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1770     return unknown;
1771
1772   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1773     return no;
1774
1775   return unknown;
1776 }
1777
1778
1779 /* inquire_direct()-- Given a fortran string, determine if the file is
1780  * suitable for direct access.  Returns a C-style string. */
1781
1782 const char *
1783 inquire_direct (const char *string, int len)
1784 {
1785   struct stat statbuf;
1786
1787   if (string == NULL)
1788     return unknown;
1789
1790   char *path = fc_strdup (string, len);
1791   int err = stat (path, &statbuf);
1792   free (path);
1793   if (err == -1)
1794     return unknown;
1795
1796   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1797     return unknown;
1798
1799   if (S_ISDIR (statbuf.st_mode) ||
1800       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1801     return no;
1802
1803   return unknown;
1804 }
1805
1806
1807 /* inquire_formatted()-- Given a fortran string, determine if the file
1808  * is suitable for formatted form.  Returns a C-style string. */
1809
1810 const char *
1811 inquire_formatted (const char *string, int len)
1812 {
1813   struct stat statbuf;
1814
1815   if (string == NULL)
1816     return unknown;
1817
1818   char *path = fc_strdup (string, len);
1819   int err = stat (path, &statbuf);
1820   free (path);
1821   if (err == -1)
1822     return unknown;
1823
1824   if (S_ISREG (statbuf.st_mode) ||
1825       S_ISBLK (statbuf.st_mode) ||
1826       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1827     return unknown;
1828
1829   if (S_ISDIR (statbuf.st_mode))
1830     return no;
1831
1832   return unknown;
1833 }
1834
1835
1836 /* inquire_unformatted()-- Given a fortran string, determine if the file
1837  * is suitable for unformatted form.  Returns a C-style string. */
1838
1839 const char *
1840 inquire_unformatted (const char *string, int len)
1841 {
1842   return inquire_formatted (string, len);
1843 }
1844
1845
1846 /* inquire_access()-- Given a fortran string, determine if the file is
1847  * suitable for access. */
1848
1849 static const char *
1850 inquire_access (const char *string, int len, int mode)
1851 {
1852   if (string == NULL)
1853     return no;
1854   char *path = fc_strdup (string, len);
1855   int res = access (path, mode);
1856   free (path);
1857   if (res == -1)
1858     return no;
1859
1860   return yes;
1861 }
1862
1863
1864 /* inquire_read()-- Given a fortran string, determine if the file is
1865  * suitable for READ access. */
1866
1867 const char *
1868 inquire_read (const char *string, int len)
1869 {
1870   return inquire_access (string, len, R_OK);
1871 }
1872
1873
1874 /* inquire_write()-- Given a fortran string, determine if the file is
1875  * suitable for READ access. */
1876
1877 const char *
1878 inquire_write (const char *string, int len)
1879 {
1880   return inquire_access (string, len, W_OK);
1881 }
1882
1883
1884 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1885  * suitable for read and write access. */
1886
1887 const char *
1888 inquire_readwrite (const char *string, int len)
1889 {
1890   return inquire_access (string, len, R_OK | W_OK);
1891 }
1892
1893
1894 int
1895 stream_isatty (stream *s)
1896 {
1897   return isatty (((unix_stream *) s)->fd);
1898 }
1899
1900 int
1901 stream_ttyname (stream *s  __attribute__ ((unused)),
1902                 char * buf  __attribute__ ((unused)),
1903                 size_t buflen  __attribute__ ((unused)))
1904 {
1905 #ifdef HAVE_TTYNAME_R
1906   return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1907 #elif defined HAVE_TTYNAME
1908   char *p;
1909   size_t plen;
1910   p = ttyname (((unix_stream *) s)->fd);
1911   if (!p)
1912     return errno;
1913   plen = strlen (p);
1914   if (buflen < plen)
1915     plen = buflen;
1916   memcpy (buf, p, plen);
1917   return 0;
1918 #else
1919   return ENOSYS;
1920 #endif
1921 }
1922
1923
1924
1925
1926 /* How files are stored:  This is an operating-system specific issue,
1927    and therefore belongs here.  There are three cases to consider.
1928
1929    Direct Access:
1930       Records are written as block of bytes corresponding to the record
1931       length of the file.  This goes for both formatted and unformatted
1932       records.  Positioning is done explicitly for each data transfer,
1933       so positioning is not much of an issue.
1934
1935    Sequential Formatted:
1936       Records are separated by newline characters.  The newline character
1937       is prohibited from appearing in a string.  If it does, this will be
1938       messed up on the next read.  End of file is also the end of a record.
1939
1940    Sequential Unformatted:
1941       In this case, we are merely copying bytes to and from main storage,
1942       yet we need to keep track of varying record lengths.  We adopt
1943       the solution used by f2c.  Each record contains a pair of length
1944       markers:
1945
1946         Length of record n in bytes
1947         Data of record n
1948         Length of record n in bytes
1949
1950         Length of record n+1 in bytes
1951         Data of record n+1
1952         Length of record n+1 in bytes
1953
1954      The length is stored at the end of a record to allow backspacing to the
1955      previous record.  Between data transfer statements, the file pointer
1956      is left pointing to the first length of the current record.
1957
1958      ENDFILE records are never explicitly stored.
1959
1960 */