libgfortran/io/unix.c

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