libgfortran/io/unix.c

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