Revert r174848,174849
[official-gcc.git] / libgfortran / io / unix.c
blobc257766d653db4bb5d323ca86709b3f1a5f65f49
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2 2011
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
28 /* Unix stream I/O module */
30 #include "io.h"
31 #include "unix.h"
32 #include <stdlib.h>
33 #include <limits.h>
35 #include <unistd.h>
36 #include <sys/stat.h>
37 #include <fcntl.h>
38 #include <assert.h>
40 #include <string.h>
41 #include <errno.h>
44 /* min macro that evaluates its arguments only once. */
45 #define min(a,b) \
46 ({ typeof (a) _a = (a); \
47 typeof (b) _b = (b); \
48 _a < _b ? _a : _b; })
51 /* For mingw, we don't identify files by their inode number, but by a
52 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
53 #ifdef __MINGW32__
55 #define WIN32_LEAN_AND_MEAN
56 #include <windows.h>
58 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
59 #undef lseek
60 #define lseek _lseeki64
61 #undef fstat
62 #define fstat _fstati64
63 #undef stat
64 #define stat _stati64
65 #endif
67 #ifndef HAVE_WORKING_STAT
68 static uint64_t
69 id_from_handle (HANDLE hFile)
71 BY_HANDLE_FILE_INFORMATION FileInformation;
73 if (hFile == INVALID_HANDLE_VALUE)
74 return 0;
76 memset (&FileInformation, 0, sizeof(FileInformation));
77 if (!GetFileInformationByHandle (hFile, &FileInformation))
78 return 0;
80 return ((uint64_t) FileInformation.nFileIndexLow)
81 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
85 static uint64_t
86 id_from_path (const char *path)
88 HANDLE hFile;
89 uint64_t res;
91 if (!path || !*path || access (path, F_OK))
92 return (uint64_t) -1;
94 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
95 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
96 NULL);
97 res = id_from_handle (hFile);
98 CloseHandle (hFile);
99 return res;
103 static uint64_t
104 id_from_fd (const int fd)
106 return id_from_handle ((HANDLE) _get_osfhandle (fd));
109 #endif
110 #endif
112 #ifndef PATH_MAX
113 #define PATH_MAX 1024
114 #endif
116 /* These flags aren't defined on all targets (mingw32), so provide them
117 here. */
118 #ifndef S_IRGRP
119 #define S_IRGRP 0
120 #endif
122 #ifndef S_IWGRP
123 #define S_IWGRP 0
124 #endif
126 #ifndef S_IROTH
127 #define S_IROTH 0
128 #endif
130 #ifndef S_IWOTH
131 #define S_IWOTH 0
132 #endif
135 #ifndef HAVE_ACCESS
137 #ifndef W_OK
138 #define W_OK 2
139 #endif
141 #ifndef R_OK
142 #define R_OK 4
143 #endif
145 #ifndef F_OK
146 #define F_OK 0
147 #endif
149 /* Fallback implementation of access() on systems that don't have it.
150 Only modes R_OK, W_OK and F_OK are used in this file. */
152 static int
153 fallback_access (const char *path, int mode)
155 int fd;
157 if ((mode & R_OK) && (fd = open (path, O_RDONLY)) < 0)
158 return -1;
159 close (fd);
161 if ((mode & W_OK) && (fd = open (path, O_WRONLY)) < 0)
162 return -1;
163 close (fd);
165 if (mode == F_OK)
167 struct stat st;
168 return stat (path, &st);
171 return 0;
174 #undef access
175 #define access fallback_access
176 #endif
179 /* Unix and internal stream I/O module */
181 static const int BUFFER_SIZE = 8192;
183 typedef struct
185 stream st;
187 gfc_offset buffer_offset; /* File offset of the start of the buffer */
188 gfc_offset physical_offset; /* Current physical file offset */
189 gfc_offset logical_offset; /* Current logical file offset */
190 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
192 char *buffer; /* Pointer to the buffer. */
193 int fd; /* The POSIX file descriptor. */
195 int active; /* Length of valid bytes in the buffer */
197 int ndirty; /* Dirty bytes starting at buffer_offset */
199 int special_file; /* =1 if the fd refers to a special file */
201 /* Cached stat(2) values. */
202 dev_t st_dev;
203 ino_t st_ino;
205 unix_stream;
208 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
209 * standard descriptors, returning a non-standard descriptor. If the
210 * user specifies that system errors should go to standard output,
211 * then closes standard output, we don't want the system errors to a
212 * file that has been given file descriptor 1 or 0. We want to send
213 * the error to the invalid descriptor. */
215 static int
216 fix_fd (int fd)
218 #ifdef HAVE_DUP
219 int input, output, error;
221 input = output = error = 0;
223 /* Unix allocates the lowest descriptors first, so a loop is not
224 required, but this order is. */
225 if (fd == STDIN_FILENO)
227 fd = dup (fd);
228 input = 1;
230 if (fd == STDOUT_FILENO)
232 fd = dup (fd);
233 output = 1;
235 if (fd == STDERR_FILENO)
237 fd = dup (fd);
238 error = 1;
241 if (input)
242 close (STDIN_FILENO);
243 if (output)
244 close (STDOUT_FILENO);
245 if (error)
246 close (STDERR_FILENO);
247 #endif
249 return fd;
253 /* If the stream corresponds to a preconnected unit, we flush the
254 corresponding C stream. This is bugware for mixed C-Fortran codes
255 where the C code doesn't flush I/O before returning. */
256 void
257 flush_if_preconnected (stream * s)
259 int fd;
261 fd = ((unix_stream *) s)->fd;
262 if (fd == STDIN_FILENO)
263 fflush (stdin);
264 else if (fd == STDOUT_FILENO)
265 fflush (stdout);
266 else if (fd == STDERR_FILENO)
267 fflush (stderr);
271 /********************************************************************
272 Raw I/O functions (read, write, seek, tell, truncate, close).
274 These functions wrap the basic POSIX I/O syscalls. Any deviation in
275 semantics is a bug, except the following: write restarts in case
276 of being interrupted by a signal, and as the first argument the
277 functions take the unix_stream struct rather than an integer file
278 descriptor. Also, for POSIX read() and write() a nbyte argument larger
279 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
280 than size_t as for POSIX read/write.
281 *********************************************************************/
283 static int
284 raw_flush (unix_stream * s __attribute__ ((unused)))
286 return 0;
289 static ssize_t
290 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
292 /* For read we can't do I/O in a loop like raw_write does, because
293 that will break applications that wait for interactive I/O. */
294 return read (s->fd, buf, nbyte);
297 static ssize_t
298 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
300 ssize_t trans, bytes_left;
301 char *buf_st;
303 bytes_left = nbyte;
304 buf_st = (char *) buf;
306 /* We must write in a loop since some systems don't restart system
307 calls in case of a signal. */
308 while (bytes_left > 0)
310 trans = write (s->fd, buf_st, bytes_left);
311 if (trans < 0)
313 if (errno == EINTR)
314 continue;
315 else
316 return trans;
318 buf_st += trans;
319 bytes_left -= trans;
322 return nbyte - bytes_left;
325 static gfc_offset
326 raw_seek (unix_stream * s, gfc_offset offset, int whence)
328 return lseek (s->fd, offset, whence);
331 static gfc_offset
332 raw_tell (unix_stream * s)
334 return lseek (s->fd, 0, SEEK_CUR);
337 static int
338 raw_truncate (unix_stream * s, gfc_offset length)
340 #ifdef __MINGW32__
341 HANDLE h;
342 gfc_offset cur;
344 if (isatty (s->fd))
346 errno = EBADF;
347 return -1;
349 h = (HANDLE) _get_osfhandle (s->fd);
350 if (h == INVALID_HANDLE_VALUE)
352 errno = EBADF;
353 return -1;
355 cur = lseek (s->fd, 0, SEEK_CUR);
356 if (cur == -1)
357 return -1;
358 if (lseek (s->fd, length, SEEK_SET) == -1)
359 goto error;
360 if (!SetEndOfFile (h))
362 errno = EBADF;
363 goto error;
365 if (lseek (s->fd, cur, SEEK_SET) == -1)
366 return -1;
367 return 0;
368 error:
369 lseek (s->fd, cur, SEEK_SET);
370 return -1;
371 #elif defined HAVE_FTRUNCATE
372 return ftruncate (s->fd, length);
373 #elif defined HAVE_CHSIZE
374 return chsize (s->fd, length);
375 #else
376 runtime_error ("required ftruncate or chsize support not present");
377 return -1;
378 #endif
381 static int
382 raw_close (unix_stream * s)
384 int retval;
386 if (s->fd != STDOUT_FILENO
387 && s->fd != STDERR_FILENO
388 && s->fd != STDIN_FILENO)
389 retval = close (s->fd);
390 else
391 retval = 0;
392 free (s);
393 return retval;
396 static int
397 raw_init (unix_stream * s)
399 s->st.read = (void *) raw_read;
400 s->st.write = (void *) raw_write;
401 s->st.seek = (void *) raw_seek;
402 s->st.tell = (void *) raw_tell;
403 s->st.trunc = (void *) raw_truncate;
404 s->st.close = (void *) raw_close;
405 s->st.flush = (void *) raw_flush;
407 s->buffer = NULL;
408 return 0;
412 /*********************************************************************
413 Buffered I/O functions. These functions have the same semantics as the
414 raw I/O functions above, except that they are buffered in order to
415 improve performance. The buffer must be flushed when switching from
416 reading to writing and vice versa.
417 *********************************************************************/
419 static int
420 buf_flush (unix_stream * s)
422 int writelen;
424 /* Flushing in read mode means discarding read bytes. */
425 s->active = 0;
427 if (s->ndirty == 0)
428 return 0;
430 if (s->file_length != -1 && s->physical_offset != s->buffer_offset
431 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
432 return -1;
434 writelen = raw_write (s, s->buffer, s->ndirty);
436 s->physical_offset = s->buffer_offset + writelen;
438 /* Don't increment file_length if the file is non-seekable. */
439 if (s->file_length != -1 && s->physical_offset > s->file_length)
440 s->file_length = s->physical_offset;
442 s->ndirty -= writelen;
443 if (s->ndirty != 0)
444 return -1;
446 #ifdef _WIN32
447 _commit (s->fd);
448 #endif
450 return 0;
453 static ssize_t
454 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
456 if (s->active == 0)
457 s->buffer_offset = s->logical_offset;
459 /* Is the data we want in the buffer? */
460 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
461 && s->buffer_offset <= s->logical_offset)
462 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
463 else
465 /* First copy the active bytes if applicable, then read the rest
466 either directly or filling the buffer. */
467 char *p;
468 int nread = 0;
469 ssize_t to_read, did_read;
470 gfc_offset new_logical;
472 p = (char *) buf;
473 if (s->logical_offset >= s->buffer_offset
474 && s->buffer_offset + s->active >= s->logical_offset)
476 nread = s->active - (s->logical_offset - s->buffer_offset);
477 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
478 nread);
479 p += nread;
481 /* At this point we consider all bytes in the buffer discarded. */
482 to_read = nbyte - nread;
483 new_logical = s->logical_offset + nread;
484 if (s->file_length != -1 && s->physical_offset != new_logical
485 && lseek (s->fd, new_logical, SEEK_SET) < 0)
486 return -1;
487 s->buffer_offset = s->physical_offset = new_logical;
488 if (to_read <= BUFFER_SIZE/2)
490 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
491 s->physical_offset += did_read;
492 s->active = did_read;
493 did_read = (did_read > to_read) ? to_read : did_read;
494 memcpy (p, s->buffer, did_read);
496 else
498 did_read = raw_read (s, p, to_read);
499 s->physical_offset += did_read;
500 s->active = 0;
502 nbyte = did_read + nread;
504 s->logical_offset += nbyte;
505 return nbyte;
508 static ssize_t
509 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
511 if (s->ndirty == 0)
512 s->buffer_offset = s->logical_offset;
514 /* Does the data fit into the buffer? As a special case, if the
515 buffer is empty and the request is bigger than BUFFER_SIZE/2,
516 write directly. This avoids the case where the buffer would have
517 to be flushed at every write. */
518 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
519 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
520 && s->buffer_offset <= s->logical_offset
521 && s->buffer_offset + s->ndirty >= s->logical_offset)
523 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
524 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
525 if (nd > s->ndirty)
526 s->ndirty = nd;
528 else
530 /* Flush, and either fill the buffer with the new data, or if
531 the request is bigger than the buffer size, write directly
532 bypassing the buffer. */
533 buf_flush (s);
534 if (nbyte <= BUFFER_SIZE/2)
536 memcpy (s->buffer, buf, nbyte);
537 s->buffer_offset = s->logical_offset;
538 s->ndirty += nbyte;
540 else
542 if (s->file_length != -1 && s->physical_offset != s->logical_offset)
544 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
545 return -1;
546 s->physical_offset = s->logical_offset;
549 nbyte = raw_write (s, buf, nbyte);
550 s->physical_offset += nbyte;
553 s->logical_offset += nbyte;
554 /* Don't increment file_length if the file is non-seekable. */
555 if (s->file_length != -1 && s->logical_offset > s->file_length)
556 s->file_length = s->logical_offset;
557 return nbyte;
560 static gfc_offset
561 buf_seek (unix_stream * s, gfc_offset offset, int whence)
563 switch (whence)
565 case SEEK_SET:
566 break;
567 case SEEK_CUR:
568 offset += s->logical_offset;
569 break;
570 case SEEK_END:
571 offset += s->file_length;
572 break;
573 default:
574 return -1;
576 if (offset < 0)
578 errno = EINVAL;
579 return -1;
581 s->logical_offset = offset;
582 return offset;
585 static gfc_offset
586 buf_tell (unix_stream * s)
588 return s->logical_offset;
591 static int
592 buf_truncate (unix_stream * s, gfc_offset length)
594 int r;
596 if (buf_flush (s) != 0)
597 return -1;
598 r = raw_truncate (s, length);
599 if (r == 0)
600 s->file_length = length;
601 return r;
604 static int
605 buf_close (unix_stream * s)
607 if (buf_flush (s) != 0)
608 return -1;
609 free (s->buffer);
610 return raw_close (s);
613 static int
614 buf_init (unix_stream * s)
616 s->st.read = (void *) buf_read;
617 s->st.write = (void *) buf_write;
618 s->st.seek = (void *) buf_seek;
619 s->st.tell = (void *) buf_tell;
620 s->st.trunc = (void *) buf_truncate;
621 s->st.close = (void *) buf_close;
622 s->st.flush = (void *) buf_flush;
624 s->buffer = get_mem (BUFFER_SIZE);
625 return 0;
629 /*********************************************************************
630 memory stream functions - These are used for internal files
632 The idea here is that a single stream structure is created and all
633 requests must be satisfied from it. The location and size of the
634 buffer is the character variable supplied to the READ or WRITE
635 statement.
637 *********************************************************************/
639 char *
640 mem_alloc_r (stream * strm, int * len)
642 unix_stream * s = (unix_stream *) strm;
643 gfc_offset n;
644 gfc_offset where = s->logical_offset;
646 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
647 return NULL;
649 n = s->buffer_offset + s->active - where;
650 if (*len > n)
651 *len = n;
653 s->logical_offset = where + *len;
655 return s->buffer + (where - s->buffer_offset);
659 char *
660 mem_alloc_r4 (stream * strm, int * len)
662 unix_stream * s = (unix_stream *) strm;
663 gfc_offset n;
664 gfc_offset where = s->logical_offset;
666 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
667 return NULL;
669 n = s->buffer_offset + s->active - where;
670 if (*len > n)
671 *len = n;
673 s->logical_offset = where + *len;
675 return s->buffer + (where - s->buffer_offset) * 4;
679 char *
680 mem_alloc_w (stream * strm, int * len)
682 unix_stream * s = (unix_stream *) strm;
683 gfc_offset m;
684 gfc_offset where = s->logical_offset;
686 m = where + *len;
688 if (where < s->buffer_offset)
689 return NULL;
691 if (m > s->file_length)
692 return NULL;
694 s->logical_offset = m;
696 return s->buffer + (where - s->buffer_offset);
700 gfc_char4_t *
701 mem_alloc_w4 (stream * strm, int * len)
703 unix_stream * s = (unix_stream *) strm;
704 gfc_offset m;
705 gfc_offset where = s->logical_offset;
706 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
708 m = where + *len;
710 if (where < s->buffer_offset)
711 return NULL;
713 if (m > s->file_length)
714 return NULL;
716 s->logical_offset = m;
717 return &result[where - s->buffer_offset];
721 /* Stream read function for character(kine=1) internal units. */
723 static ssize_t
724 mem_read (stream * s, void * buf, ssize_t nbytes)
726 void *p;
727 int nb = nbytes;
729 p = mem_alloc_r (s, &nb);
730 if (p)
732 memcpy (buf, p, nb);
733 return (ssize_t) nb;
735 else
736 return 0;
740 /* Stream read function for chracter(kind=4) internal units. */
742 static ssize_t
743 mem_read4 (stream * s, void * buf, ssize_t nbytes)
745 void *p;
746 int nb = nbytes;
748 p = mem_alloc_r (s, &nb);
749 if (p)
751 memcpy (buf, p, nb);
752 return (ssize_t) nb;
754 else
755 return 0;
759 /* Stream write function for character(kind=1) internal units. */
761 static ssize_t
762 mem_write (stream * s, const void * buf, ssize_t nbytes)
764 void *p;
765 int nb = nbytes;
767 p = mem_alloc_w (s, &nb);
768 if (p)
770 memcpy (p, buf, nb);
771 return (ssize_t) nb;
773 else
774 return 0;
778 /* Stream write function for character(kind=4) internal units. */
780 static ssize_t
781 mem_write4 (stream * s, const void * buf, ssize_t nwords)
783 gfc_char4_t *p;
784 int nw = nwords;
786 p = mem_alloc_w4 (s, &nw);
787 if (p)
789 while (nw--)
790 *p++ = (gfc_char4_t) *((char *) buf);
791 return nwords;
793 else
794 return 0;
798 static gfc_offset
799 mem_seek (stream * strm, gfc_offset offset, int whence)
801 unix_stream * s = (unix_stream *) strm;
802 switch (whence)
804 case SEEK_SET:
805 break;
806 case SEEK_CUR:
807 offset += s->logical_offset;
808 break;
809 case SEEK_END:
810 offset += s->file_length;
811 break;
812 default:
813 return -1;
816 /* Note that for internal array I/O it's actually possible to have a
817 negative offset, so don't check for that. */
818 if (offset > s->file_length)
820 errno = EINVAL;
821 return -1;
824 s->logical_offset = offset;
826 /* Returning < 0 is the error indicator for sseek(), so return 0 if
827 offset is negative. Thus if the return value is 0, the caller
828 has to use stell() to get the real value of logical_offset. */
829 if (offset >= 0)
830 return offset;
831 return 0;
835 static gfc_offset
836 mem_tell (stream * s)
838 return ((unix_stream *)s)->logical_offset;
842 static int
843 mem_truncate (unix_stream * s __attribute__ ((unused)),
844 gfc_offset length __attribute__ ((unused)))
846 return 0;
850 static int
851 mem_flush (unix_stream * s __attribute__ ((unused)))
853 return 0;
857 static int
858 mem_close (unix_stream * s)
860 free (s);
862 return 0;
866 /*********************************************************************
867 Public functions -- A reimplementation of this module needs to
868 define functional equivalents of the following.
869 *********************************************************************/
871 /* open_internal()-- Returns a stream structure from a character(kind=1)
872 internal file */
874 stream *
875 open_internal (char *base, int length, gfc_offset offset)
877 unix_stream *s;
879 s = get_mem (sizeof (unix_stream));
880 memset (s, '\0', sizeof (unix_stream));
882 s->buffer = base;
883 s->buffer_offset = offset;
885 s->logical_offset = 0;
886 s->active = s->file_length = length;
888 s->st.close = (void *) mem_close;
889 s->st.seek = (void *) mem_seek;
890 s->st.tell = (void *) mem_tell;
891 s->st.trunc = (void *) mem_truncate;
892 s->st.read = (void *) mem_read;
893 s->st.write = (void *) mem_write;
894 s->st.flush = (void *) mem_flush;
896 return (stream *) s;
899 /* open_internal4()-- Returns a stream structure from a character(kind=4)
900 internal file */
902 stream *
903 open_internal4 (char *base, int length, gfc_offset offset)
905 unix_stream *s;
907 s = get_mem (sizeof (unix_stream));
908 memset (s, '\0', sizeof (unix_stream));
910 s->buffer = base;
911 s->buffer_offset = offset;
913 s->logical_offset = 0;
914 s->active = s->file_length = length;
916 s->st.close = (void *) mem_close;
917 s->st.seek = (void *) mem_seek;
918 s->st.tell = (void *) mem_tell;
919 s->st.trunc = (void *) mem_truncate;
920 s->st.read = (void *) mem_read4;
921 s->st.write = (void *) mem_write4;
922 s->st.flush = (void *) mem_flush;
924 return (stream *) s;
928 /* fd_to_stream()-- Given an open file descriptor, build a stream
929 * around it. */
931 static stream *
932 fd_to_stream (int fd)
934 struct stat statbuf;
935 unix_stream *s;
937 s = get_mem (sizeof (unix_stream));
938 memset (s, '\0', sizeof (unix_stream));
940 s->fd = fd;
941 s->buffer_offset = 0;
942 s->physical_offset = 0;
943 s->logical_offset = 0;
945 /* Get the current length of the file. */
947 fstat (fd, &statbuf);
949 s->st_dev = statbuf.st_dev;
950 s->st_ino = statbuf.st_ino;
951 s->special_file = !S_ISREG (statbuf.st_mode);
953 if (S_ISREG (statbuf.st_mode))
954 s->file_length = statbuf.st_size;
955 else if (S_ISBLK (statbuf.st_mode))
957 /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)? */
958 gfc_offset cur = lseek (fd, 0, SEEK_CUR);
959 s->file_length = lseek (fd, 0, SEEK_END);
960 lseek (fd, cur, SEEK_SET);
962 else
963 s->file_length = -1;
965 if (!(S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
966 || options.all_unbuffered
967 ||(options.unbuffered_preconnected &&
968 (s->fd == STDIN_FILENO
969 || s->fd == STDOUT_FILENO
970 || s->fd == STDERR_FILENO))
971 || isatty (s->fd))
972 raw_init (s);
973 else
974 buf_init (s);
976 return (stream *) s;
980 /* Given the Fortran unit number, convert it to a C file descriptor. */
983 unit_to_fd (int unit)
985 gfc_unit *us;
986 int fd;
988 us = find_unit (unit);
989 if (us == NULL)
990 return -1;
992 fd = ((unix_stream *) us->s)->fd;
993 unlock_unit (us);
994 return fd;
998 /* unpack_filename()-- Given a fortran string and a pointer to a
999 * buffer that is PATH_MAX characters, convert the fortran string to a
1000 * C string in the buffer. Returns nonzero if this is not possible. */
1003 unpack_filename (char *cstring, const char *fstring, int len)
1005 if (fstring == NULL)
1006 return EFAULT;
1007 len = fstrlen (fstring, len);
1008 if (len >= PATH_MAX)
1009 return ENAMETOOLONG;
1011 memmove (cstring, fstring, len);
1012 cstring[len] = '\0';
1014 return 0;
1018 /* tempfile()-- Generate a temporary filename for a scratch file and
1019 * open it. mkstemp() opens the file for reading and writing, but the
1020 * library mode prevents anything that is not allowed. The descriptor
1021 * is returned, which is -1 on error. The template is pointed to by
1022 * opp->file, which is copied into the unit structure
1023 * and freed later. */
1025 static int
1026 tempfile (st_parameter_open *opp)
1028 const char *tempdir;
1029 char *template;
1030 const char *slash = "/";
1031 int fd;
1032 size_t tempdirlen;
1034 #ifndef HAVE_MKSTEMP
1035 int count;
1036 size_t slashlen;
1037 #endif
1039 tempdir = getenv ("GFORTRAN_TMPDIR");
1040 #ifdef __MINGW32__
1041 if (tempdir == NULL)
1043 char buffer[MAX_PATH + 1];
1044 DWORD ret;
1045 ret = GetTempPath (MAX_PATH, buffer);
1046 /* If we are not able to get a temp-directory, we use
1047 current directory. */
1048 if (ret > MAX_PATH || !ret)
1049 buffer[0] = 0;
1050 else
1051 buffer[ret] = 0;
1052 tempdir = strdup (buffer);
1054 #else
1055 if (tempdir == NULL)
1056 tempdir = getenv ("TMP");
1057 if (tempdir == NULL)
1058 tempdir = getenv ("TEMP");
1059 if (tempdir == NULL)
1060 tempdir = DEFAULT_TEMPDIR;
1061 #endif
1063 /* Check for special case that tempdir contains slash
1064 or backslash at end. */
1065 tempdirlen = strlen (tempdir);
1066 if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1067 #ifdef __MINGW32__
1068 || tempdir[tempdirlen - 1] == '\\'
1069 #endif
1071 slash = "";
1073 // Take care that the template is longer in the mktemp() branch.
1074 template = get_mem (tempdirlen + 23);
1076 #ifdef HAVE_MKSTEMP
1077 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1078 tempdir, slash);
1080 fd = mkstemp (template);
1082 #else /* HAVE_MKSTEMP */
1083 fd = -1;
1084 count = 0;
1085 slashlen = strlen (slash);
1088 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1089 tempdir, slash);
1090 if (count > 0)
1092 int c = count;
1093 template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1094 c /= 26;
1095 template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1096 c /= 26;
1097 template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1098 if (c >= 26)
1099 break;
1102 if (!mktemp (template))
1104 errno = EEXIST;
1105 count++;
1106 continue;
1109 #if defined(HAVE_CRLF) && defined(O_BINARY)
1110 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1111 S_IREAD | S_IWRITE);
1112 #else
1113 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1114 #endif
1116 while (fd == -1 && errno == EEXIST);
1117 #endif /* HAVE_MKSTEMP */
1119 opp->file = template;
1120 opp->file_len = strlen (template); /* Don't include trailing nul */
1122 return fd;
1126 /* regular_file()-- Open a regular file.
1127 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1128 * unless an error occurs.
1129 * Returns the descriptor, which is less than zero on error. */
1131 static int
1132 regular_file (st_parameter_open *opp, unit_flags *flags)
1134 char path[min(PATH_MAX, opp->file_len + 1)];
1135 int mode;
1136 int rwflag;
1137 int crflag;
1138 int fd;
1139 int err;
1141 err = unpack_filename (path, opp->file, opp->file_len);
1142 if (err)
1144 errno = err; /* Fake an OS error */
1145 return -1;
1148 #ifdef __CYGWIN__
1149 if (opp->file_len == 7)
1151 if (strncmp (path, "CONOUT$", 7) == 0
1152 || strncmp (path, "CONERR$", 7) == 0)
1154 fd = open ("/dev/conout", O_WRONLY);
1155 flags->action = ACTION_WRITE;
1156 return fd;
1160 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1162 fd = open ("/dev/conin", O_RDONLY);
1163 flags->action = ACTION_READ;
1164 return fd;
1166 #endif
1169 #ifdef __MINGW32__
1170 if (opp->file_len == 7)
1172 if (strncmp (path, "CONOUT$", 7) == 0
1173 || strncmp (path, "CONERR$", 7) == 0)
1175 fd = open ("CONOUT$", O_WRONLY);
1176 flags->action = ACTION_WRITE;
1177 return fd;
1181 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1183 fd = open ("CONIN$", O_RDONLY);
1184 flags->action = ACTION_READ;
1185 return fd;
1187 #endif
1189 rwflag = 0;
1191 switch (flags->action)
1193 case ACTION_READ:
1194 rwflag = O_RDONLY;
1195 break;
1197 case ACTION_WRITE:
1198 rwflag = O_WRONLY;
1199 break;
1201 case ACTION_READWRITE:
1202 case ACTION_UNSPECIFIED:
1203 rwflag = O_RDWR;
1204 break;
1206 default:
1207 internal_error (&opp->common, "regular_file(): Bad action");
1210 switch (flags->status)
1212 case STATUS_NEW:
1213 crflag = O_CREAT | O_EXCL;
1214 break;
1216 case STATUS_OLD: /* open will fail if the file does not exist*/
1217 crflag = 0;
1218 break;
1220 case STATUS_UNKNOWN:
1221 case STATUS_SCRATCH:
1222 crflag = O_CREAT;
1223 break;
1225 case STATUS_REPLACE:
1226 crflag = O_CREAT | O_TRUNC;
1227 break;
1229 default:
1230 internal_error (&opp->common, "regular_file(): Bad status");
1233 /* rwflag |= O_LARGEFILE; */
1235 #if defined(HAVE_CRLF) && defined(O_BINARY)
1236 crflag |= O_BINARY;
1237 #endif
1239 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1240 fd = open (path, rwflag | crflag, mode);
1241 if (flags->action != ACTION_UNSPECIFIED)
1242 return fd;
1244 if (fd >= 0)
1246 flags->action = ACTION_READWRITE;
1247 return fd;
1249 if (errno != EACCES && errno != EROFS)
1250 return fd;
1252 /* retry for read-only access */
1253 rwflag = O_RDONLY;
1254 fd = open (path, rwflag | crflag, mode);
1255 if (fd >=0)
1257 flags->action = ACTION_READ;
1258 return fd; /* success */
1261 if (errno != EACCES)
1262 return fd; /* failure */
1264 /* retry for write-only access */
1265 rwflag = O_WRONLY;
1266 fd = open (path, rwflag | crflag, mode);
1267 if (fd >=0)
1269 flags->action = ACTION_WRITE;
1270 return fd; /* success */
1272 return fd; /* failure */
1276 /* open_external()-- Open an external file, unix specific version.
1277 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1278 * Returns NULL on operating system error. */
1280 stream *
1281 open_external (st_parameter_open *opp, unit_flags *flags)
1283 int fd;
1285 if (flags->status == STATUS_SCRATCH)
1287 fd = tempfile (opp);
1288 if (flags->action == ACTION_UNSPECIFIED)
1289 flags->action = ACTION_READWRITE;
1291 #if HAVE_UNLINK_OPEN_FILE
1292 /* We can unlink scratch files now and it will go away when closed. */
1293 if (fd >= 0)
1294 unlink (opp->file);
1295 #endif
1297 else
1299 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1300 * if it succeeds */
1301 fd = regular_file (opp, flags);
1304 if (fd < 0)
1305 return NULL;
1306 fd = fix_fd (fd);
1308 return fd_to_stream (fd);
1312 /* input_stream()-- Return a stream pointer to the default input stream.
1313 * Called on initialization. */
1315 stream *
1316 input_stream (void)
1318 return fd_to_stream (STDIN_FILENO);
1322 /* output_stream()-- Return a stream pointer to the default output stream.
1323 * Called on initialization. */
1325 stream *
1326 output_stream (void)
1328 stream * s;
1330 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1331 setmode (STDOUT_FILENO, O_BINARY);
1332 #endif
1334 s = fd_to_stream (STDOUT_FILENO);
1335 return s;
1339 /* error_stream()-- Return a stream pointer to the default error stream.
1340 * Called on initialization. */
1342 stream *
1343 error_stream (void)
1345 stream * s;
1347 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1348 setmode (STDERR_FILENO, O_BINARY);
1349 #endif
1351 s = fd_to_stream (STDERR_FILENO);
1352 return s;
1356 /* compare_file_filename()-- Given an open stream and a fortran string
1357 * that is a filename, figure out if the file is the same as the
1358 * filename. */
1361 compare_file_filename (gfc_unit *u, const char *name, int len)
1363 char path[min(PATH_MAX, len + 1)];
1364 struct stat st;
1365 #ifdef HAVE_WORKING_STAT
1366 unix_stream *s;
1367 #else
1368 # ifdef __MINGW32__
1369 uint64_t id1, id2;
1370 # endif
1371 #endif
1373 if (unpack_filename (path, name, len))
1374 return 0; /* Can't be the same */
1376 /* If the filename doesn't exist, then there is no match with the
1377 * existing file. */
1379 if (stat (path, &st) < 0)
1380 return 0;
1382 #ifdef HAVE_WORKING_STAT
1383 s = (unix_stream *) (u->s);
1384 return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1385 #else
1387 # ifdef __MINGW32__
1388 /* We try to match files by a unique ID. On some filesystems (network
1389 fs and FAT), we can't generate this unique ID, and will simply compare
1390 filenames. */
1391 id1 = id_from_path (path);
1392 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1393 if (id1 || id2)
1394 return (id1 == id2);
1395 # endif
1397 if (len != u->file_len)
1398 return 0;
1399 return (memcmp(path, u->file, len) == 0);
1400 #endif
1404 #ifdef HAVE_WORKING_STAT
1405 # define FIND_FILE0_DECL struct stat *st
1406 # define FIND_FILE0_ARGS st
1407 #else
1408 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1409 # define FIND_FILE0_ARGS id, file, file_len
1410 #endif
1412 /* find_file0()-- Recursive work function for find_file() */
1414 static gfc_unit *
1415 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1417 gfc_unit *v;
1418 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1419 uint64_t id1;
1420 #endif
1422 if (u == NULL)
1423 return NULL;
1425 #ifdef HAVE_WORKING_STAT
1426 if (u->s != NULL)
1428 unix_stream *s = (unix_stream *) (u->s);
1429 if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1430 return u;
1432 #else
1433 # ifdef __MINGW32__
1434 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1436 if (id == id1)
1437 return u;
1439 else
1440 # endif
1441 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1442 return u;
1443 #endif
1445 v = find_file0 (u->left, FIND_FILE0_ARGS);
1446 if (v != NULL)
1447 return v;
1449 v = find_file0 (u->right, FIND_FILE0_ARGS);
1450 if (v != NULL)
1451 return v;
1453 return NULL;
1457 /* find_file()-- Take the current filename and see if there is a unit
1458 * that has the file already open. Returns a pointer to the unit if so. */
1460 gfc_unit *
1461 find_file (const char *file, gfc_charlen_type file_len)
1463 char path[min(PATH_MAX, file_len + 1)];
1464 struct stat st[1];
1465 gfc_unit *u;
1466 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1467 uint64_t id = 0ULL;
1468 #endif
1470 if (unpack_filename (path, file, file_len))
1471 return NULL;
1473 if (stat (path, &st[0]) < 0)
1474 return NULL;
1476 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1477 id = id_from_path (path);
1478 #endif
1480 __gthread_mutex_lock (&unit_lock);
1481 retry:
1482 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1483 if (u != NULL)
1485 /* Fast path. */
1486 if (! __gthread_mutex_trylock (&u->lock))
1488 /* assert (u->closed == 0); */
1489 __gthread_mutex_unlock (&unit_lock);
1490 return u;
1493 inc_waiting_locked (u);
1495 __gthread_mutex_unlock (&unit_lock);
1496 if (u != NULL)
1498 __gthread_mutex_lock (&u->lock);
1499 if (u->closed)
1501 __gthread_mutex_lock (&unit_lock);
1502 __gthread_mutex_unlock (&u->lock);
1503 if (predec_waiting_locked (u) == 0)
1504 free (u);
1505 goto retry;
1508 dec_waiting_unlocked (u);
1510 return u;
1513 static gfc_unit *
1514 flush_all_units_1 (gfc_unit *u, int min_unit)
1516 while (u != NULL)
1518 if (u->unit_number > min_unit)
1520 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1521 if (r != NULL)
1522 return r;
1524 if (u->unit_number >= min_unit)
1526 if (__gthread_mutex_trylock (&u->lock))
1527 return u;
1528 if (u->s)
1529 sflush (u->s);
1530 __gthread_mutex_unlock (&u->lock);
1532 u = u->right;
1534 return NULL;
1537 void
1538 flush_all_units (void)
1540 gfc_unit *u;
1541 int min_unit = 0;
1543 __gthread_mutex_lock (&unit_lock);
1546 u = flush_all_units_1 (unit_root, min_unit);
1547 if (u != NULL)
1548 inc_waiting_locked (u);
1549 __gthread_mutex_unlock (&unit_lock);
1550 if (u == NULL)
1551 return;
1553 __gthread_mutex_lock (&u->lock);
1555 min_unit = u->unit_number + 1;
1557 if (u->closed == 0)
1559 sflush (u->s);
1560 __gthread_mutex_lock (&unit_lock);
1561 __gthread_mutex_unlock (&u->lock);
1562 (void) predec_waiting_locked (u);
1564 else
1566 __gthread_mutex_lock (&unit_lock);
1567 __gthread_mutex_unlock (&u->lock);
1568 if (predec_waiting_locked (u) == 0)
1569 free (u);
1572 while (1);
1576 /* delete_file()-- Given a unit structure, delete the file associated
1577 * with the unit. Returns nonzero if something went wrong. */
1580 delete_file (gfc_unit * u)
1582 char path[min(PATH_MAX, u->file_len + 1)];
1583 int err = unpack_filename (path, u->file, u->file_len);
1585 if (err)
1586 { /* Shouldn't be possible */
1587 errno = err;
1588 return 1;
1591 return unlink (path);
1595 /* file_exists()-- Returns nonzero if the current filename exists on
1596 * the system */
1599 file_exists (const char *file, gfc_charlen_type file_len)
1601 char path[min(PATH_MAX, file_len + 1)];
1603 if (unpack_filename (path, file, file_len))
1604 return 0;
1606 return !(access (path, F_OK));
1610 /* file_size()-- Returns the size of the file. */
1612 GFC_IO_INT
1613 file_size (const char *file, gfc_charlen_type file_len)
1615 char path[min(PATH_MAX, file_len + 1)];
1616 struct stat statbuf;
1618 if (unpack_filename (path, file, file_len))
1619 return -1;
1621 if (stat (path, &statbuf) < 0)
1622 return -1;
1624 return (GFC_IO_INT) statbuf.st_size;
1627 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1629 /* inquire_sequential()-- Given a fortran string, determine if the
1630 * file is suitable for sequential access. Returns a C-style
1631 * string. */
1633 const char *
1634 inquire_sequential (const char *string, int len)
1636 char path[min(PATH_MAX, len + 1)];
1637 struct stat statbuf;
1639 if (string == NULL ||
1640 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1641 return unknown;
1643 if (S_ISREG (statbuf.st_mode) ||
1644 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1645 return unknown;
1647 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1648 return no;
1650 return unknown;
1654 /* inquire_direct()-- Given a fortran string, determine if the file is
1655 * suitable for direct access. Returns a C-style string. */
1657 const char *
1658 inquire_direct (const char *string, int len)
1660 char path[min(PATH_MAX, len + 1)];
1661 struct stat statbuf;
1663 if (string == NULL ||
1664 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1665 return unknown;
1667 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1668 return unknown;
1670 if (S_ISDIR (statbuf.st_mode) ||
1671 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1672 return no;
1674 return unknown;
1678 /* inquire_formatted()-- Given a fortran string, determine if the file
1679 * is suitable for formatted form. Returns a C-style string. */
1681 const char *
1682 inquire_formatted (const char *string, int len)
1684 char path[min(PATH_MAX, len + 1)];
1685 struct stat statbuf;
1687 if (string == NULL ||
1688 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1689 return unknown;
1691 if (S_ISREG (statbuf.st_mode) ||
1692 S_ISBLK (statbuf.st_mode) ||
1693 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1694 return unknown;
1696 if (S_ISDIR (statbuf.st_mode))
1697 return no;
1699 return unknown;
1703 /* inquire_unformatted()-- Given a fortran string, determine if the file
1704 * is suitable for unformatted form. Returns a C-style string. */
1706 const char *
1707 inquire_unformatted (const char *string, int len)
1709 return inquire_formatted (string, len);
1713 /* inquire_access()-- Given a fortran string, determine if the file is
1714 * suitable for access. */
1716 static const char *
1717 inquire_access (const char *string, int len, int mode)
1719 char path[min(PATH_MAX, len + 1)];
1721 if (string == NULL || unpack_filename (path, string, len) ||
1722 access (path, mode) < 0)
1723 return no;
1725 return yes;
1729 /* inquire_read()-- Given a fortran string, determine if the file is
1730 * suitable for READ access. */
1732 const char *
1733 inquire_read (const char *string, int len)
1735 return inquire_access (string, len, R_OK);
1739 /* inquire_write()-- Given a fortran string, determine if the file is
1740 * suitable for READ access. */
1742 const char *
1743 inquire_write (const char *string, int len)
1745 return inquire_access (string, len, W_OK);
1749 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1750 * suitable for read and write access. */
1752 const char *
1753 inquire_readwrite (const char *string, int len)
1755 return inquire_access (string, len, R_OK | W_OK);
1759 /* file_length()-- Return the file length in bytes, -1 if unknown */
1761 gfc_offset
1762 file_length (stream * s)
1764 gfc_offset curr, end;
1765 if (!is_seekable (s))
1766 return -1;
1767 curr = stell (s);
1768 if (curr == -1)
1769 return curr;
1770 end = sseek (s, 0, SEEK_END);
1771 sseek (s, curr, SEEK_SET);
1772 return end;
1776 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1777 * it is not */
1780 is_seekable (stream *s)
1782 /* By convention, if file_length == -1, the file is not
1783 seekable. */
1784 return ((unix_stream *) s)->file_length!=-1;
1788 /* is_special()-- Return nonzero if the stream is not a regular file. */
1791 is_special (stream *s)
1793 return ((unix_stream *) s)->special_file;
1798 stream_isatty (stream *s)
1800 return isatty (((unix_stream *) s)->fd);
1804 stream_ttyname (stream *s __attribute__ ((unused)),
1805 char * buf __attribute__ ((unused)),
1806 size_t buflen __attribute__ ((unused)))
1808 #ifdef HAVE_TTYNAME_R
1809 return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1810 #elif defined HAVE_TTYNAME
1811 char *p;
1812 size_t plen;
1813 p = ttyname (((unix_stream *) s)->fd);
1814 if (!p)
1815 return errno;
1816 plen = strlen (p);
1817 if (buflen < plen)
1818 plen = buflen;
1819 memcpy (buf, p, plen);
1820 return 0;
1821 #else
1822 return ENOSYS;
1823 #endif
1829 /* How files are stored: This is an operating-system specific issue,
1830 and therefore belongs here. There are three cases to consider.
1832 Direct Access:
1833 Records are written as block of bytes corresponding to the record
1834 length of the file. This goes for both formatted and unformatted
1835 records. Positioning is done explicitly for each data transfer,
1836 so positioning is not much of an issue.
1838 Sequential Formatted:
1839 Records are separated by newline characters. The newline character
1840 is prohibited from appearing in a string. If it does, this will be
1841 messed up on the next read. End of file is also the end of a record.
1843 Sequential Unformatted:
1844 In this case, we are merely copying bytes to and from main storage,
1845 yet we need to keep track of varying record lengths. We adopt
1846 the solution used by f2c. Each record contains a pair of length
1847 markers:
1849 Length of record n in bytes
1850 Data of record n
1851 Length of record n in bytes
1853 Length of record n+1 in bytes
1854 Data of record n+1
1855 Length of record n+1 in bytes
1857 The length is stored at the end of a record to allow backspacing to the
1858 previous record. Between data transfer statements, the file pointer
1859 is left pointing to the first length of the current record.
1861 ENDFILE records are never explicitly stored.