1 /* Copyright (C) 2002-2019 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 /* Unix stream I/O module */
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. */
48 #define WIN32_LEAN_AND_MEAN
51 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
53 #define lseek _lseeki64
55 #define fstat _fstati64
60 #ifndef HAVE_WORKING_STAT
62 id_from_handle (HANDLE hFile
)
64 BY_HANDLE_FILE_INFORMATION FileInformation
;
66 if (hFile
== INVALID_HANDLE_VALUE
)
69 memset (&FileInformation
, 0, sizeof(FileInformation
));
70 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
73 return ((uint64_t) FileInformation
.nFileIndexLow
)
74 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
79 id_from_path (const char *path
)
84 if (!path
|| !*path
|| access (path
, F_OK
))
87 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
88 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
90 res
= id_from_handle (hFile
);
97 id_from_fd (const int fd
)
99 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
102 #endif /* HAVE_WORKING_STAT */
105 /* On mingw, we don't use umask in tempfile_open(), because it
106 doesn't support the user/group/other-based permissions. */
109 #endif /* __MINGW32__ */
112 /* These flags aren't defined on all targets (mingw32), so provide them
145 /* Fallback implementation of access() on systems that don't have it.
146 Only modes R_OK, W_OK and F_OK are used in this file. */
149 fallback_access (const char *path
, int mode
)
155 if ((fd
= open (path
, O_RDONLY
)) < 0)
163 if ((fd
= open (path
, O_WRONLY
)) < 0)
172 return stat (path
, &st
);
179 #define access fallback_access
183 /* Fallback directory for creating temporary files. P_tmpdir is
184 defined on many POSIX platforms. */
187 #define P_tmpdir _P_tmpdir /* MinGW */
189 #define P_tmpdir "/tmp"
194 /* Unix and internal stream I/O module */
196 static const int FORMATTED_BUFFER_SIZE_DEFAULT
= 8192;
197 static const int UNFORMATTED_BUFFER_SIZE_DEFAULT
= 128*1024;
203 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
204 gfc_offset physical_offset
; /* Current physical file offset */
205 gfc_offset logical_offset
; /* Current logical file offset */
206 gfc_offset file_length
; /* Length of the file. */
208 char *buffer
; /* Pointer to the buffer. */
209 ssize_t buffer_size
; /* Length of the buffer. */
210 int fd
; /* The POSIX file descriptor. */
212 int active
; /* Length of valid bytes in the buffer */
214 int ndirty
; /* Dirty bytes starting at buffer_offset */
216 /* Cached stat(2) values. */
220 bool unbuffered
; /* Buffer should be flushed after each I/O statement. */
225 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
226 standard descriptors, returning a non-standard descriptor. If the
227 user specifies that system errors should go to standard output,
228 then closes standard output, we don't want the system errors to a
229 file that has been given file descriptor 1 or 0. We want to send
230 the error to the invalid descriptor. */
236 int input
, output
, error
;
238 input
= output
= error
= 0;
240 /* Unix allocates the lowest descriptors first, so a loop is not
241 required, but this order is. */
242 if (fd
== STDIN_FILENO
)
247 if (fd
== STDOUT_FILENO
)
252 if (fd
== STDERR_FILENO
)
259 close (STDIN_FILENO
);
261 close (STDOUT_FILENO
);
263 close (STDERR_FILENO
);
270 /* If the stream corresponds to a preconnected unit, we flush the
271 corresponding C stream. This is bugware for mixed C-Fortran codes
272 where the C code doesn't flush I/O before returning. */
274 flush_if_preconnected (stream
*s
)
278 fd
= ((unix_stream
*) s
)->fd
;
279 if (fd
== STDIN_FILENO
)
281 else if (fd
== STDOUT_FILENO
)
283 else if (fd
== STDERR_FILENO
)
288 /********************************************************************
289 Raw I/O functions (read, write, seek, tell, truncate, close).
291 These functions wrap the basic POSIX I/O syscalls. Any deviation in
292 semantics is a bug, except the following: write restarts in case
293 of being interrupted by a signal, and as the first argument the
294 functions take the unix_stream struct rather than an integer file
295 descriptor. Also, for POSIX read() and write() a nbyte argument larger
296 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
297 than size_t as for POSIX read/write.
298 *********************************************************************/
301 raw_flush (unix_stream
*s
__attribute__ ((unused
)))
306 /* Write/read at most 2 GB - 4k chunks at a time. Linux never reads or
307 writes more than this, and there are reports that macOS fails for
308 larger than 2 GB as well. */
309 #define MAX_CHUNK 2147479552
312 raw_read (unix_stream
*s
, void *buf
, ssize_t nbyte
)
314 /* For read we can't do I/O in a loop like raw_write does, because
315 that will break applications that wait for interactive I/O. We
316 still can loop around EINTR, though. This however causes a
317 problem for large reads which must be chunked, see comment above.
318 So assume that if the size is larger than the chunk size, we're
319 reading from a file and not the terminal. */
320 if (nbyte
<= MAX_CHUNK
)
324 ssize_t trans
= read (s
->fd
, buf
, nbyte
);
325 if (trans
== -1 && errno
== EINTR
)
332 ssize_t bytes_left
= nbyte
;
334 while (bytes_left
> 0)
336 ssize_t to_read
= bytes_left
< MAX_CHUNK
? bytes_left
: MAX_CHUNK
;
337 ssize_t trans
= read (s
->fd
, buf_st
, to_read
);
348 return nbyte
- bytes_left
;
353 raw_write (unix_stream
*s
, const void *buf
, ssize_t nbyte
)
355 ssize_t trans
, bytes_left
;
359 buf_st
= (char *) buf
;
361 /* We must write in a loop since some systems don't restart system
362 calls in case of a signal. Also some systems might fail outright
363 if we try to write more than 2 GB in a single syscall, so chunk
365 while (bytes_left
> 0)
367 ssize_t to_write
= bytes_left
< MAX_CHUNK
? bytes_left
: MAX_CHUNK
;
368 trans
= write (s
->fd
, buf_st
, to_write
);
380 return nbyte
- bytes_left
;
384 raw_seek (unix_stream
*s
, gfc_offset offset
, int whence
)
388 gfc_offset off
= lseek (s
->fd
, offset
, whence
);
389 if (off
== (gfc_offset
) -1 && errno
== EINTR
)
396 raw_tell (unix_stream
*s
)
400 gfc_offset off
= lseek (s
->fd
, 0, SEEK_CUR
);
401 if (off
== (gfc_offset
) -1 && errno
== EINTR
)
408 raw_size (unix_stream
*s
)
411 if (TEMP_FAILURE_RETRY (fstat (s
->fd
, &statbuf
)) == -1)
413 if (S_ISREG (statbuf
.st_mode
))
414 return statbuf
.st_size
;
420 raw_truncate (unix_stream
*s
, gfc_offset length
)
431 h
= (HANDLE
) _get_osfhandle (s
->fd
);
432 if (h
== INVALID_HANDLE_VALUE
)
437 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
440 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
442 if (!SetEndOfFile (h
))
447 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
451 lseek (s
->fd
, cur
, SEEK_SET
);
453 #elif defined HAVE_FTRUNCATE
454 if (TEMP_FAILURE_RETRY (ftruncate (s
->fd
, length
)) == -1)
457 #elif defined HAVE_CHSIZE
458 return chsize (s
->fd
, length
);
460 runtime_error ("required ftruncate or chsize support not present");
466 raw_close (unix_stream
*s
)
472 else if (s
->fd
!= STDOUT_FILENO
473 && s
->fd
!= STDERR_FILENO
474 && s
->fd
!= STDIN_FILENO
)
476 retval
= close (s
->fd
);
477 /* close() and EINTR is special, as the file descriptor is
478 deallocated before doing anything that might cause the
479 operation to be interrupted. Thus if we get EINTR the best we
480 can do is ignore it and continue (otherwise if we try again
481 the file descriptor may have been allocated again to some
483 if (retval
== -1 && errno
== EINTR
)
493 raw_markeor (unix_stream
*s
__attribute__ ((unused
)))
498 static const struct stream_vtable raw_vtable
= {
499 .read
= (void *) raw_read
,
500 .write
= (void *) raw_write
,
501 .seek
= (void *) raw_seek
,
502 .tell
= (void *) raw_tell
,
503 .size
= (void *) raw_size
,
504 .trunc
= (void *) raw_truncate
,
505 .close
= (void *) raw_close
,
506 .flush
= (void *) raw_flush
,
507 .markeor
= (void *) raw_markeor
511 raw_init (unix_stream
*s
)
513 s
->st
.vptr
= &raw_vtable
;
520 /*********************************************************************
521 Buffered I/O functions. These functions have the same semantics as the
522 raw I/O functions above, except that they are buffered in order to
523 improve performance. The buffer must be flushed when switching from
524 reading to writing and vice versa.
525 *********************************************************************/
528 buf_flush (unix_stream
*s
)
532 /* Flushing in read mode means discarding read bytes. */
538 if (s
->physical_offset
!= s
->buffer_offset
539 && raw_seek (s
, s
->buffer_offset
, SEEK_SET
) < 0)
542 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
544 s
->physical_offset
= s
->buffer_offset
+ writelen
;
546 if (s
->physical_offset
> s
->file_length
)
547 s
->file_length
= s
->physical_offset
;
549 s
->ndirty
-= writelen
;
557 buf_read (unix_stream
*s
, void *buf
, ssize_t nbyte
)
560 s
->buffer_offset
= s
->logical_offset
;
562 /* Is the data we want in the buffer? */
563 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
564 && s
->buffer_offset
<= s
->logical_offset
)
566 /* When nbyte == 0, buf can be NULL which would lead to undefined
567 behavior if we called memcpy(). */
569 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
574 /* First copy the active bytes if applicable, then read the rest
575 either directly or filling the buffer. */
578 ssize_t to_read
, did_read
;
579 gfc_offset new_logical
;
582 if (s
->logical_offset
>= s
->buffer_offset
583 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
585 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
586 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
590 /* At this point we consider all bytes in the buffer discarded. */
591 to_read
= nbyte
- nread
;
592 new_logical
= s
->logical_offset
+ nread
;
593 if (s
->physical_offset
!= new_logical
594 && raw_seek (s
, new_logical
, SEEK_SET
) < 0)
596 s
->buffer_offset
= s
->physical_offset
= new_logical
;
597 if (to_read
<= s
->buffer_size
/2)
599 did_read
= raw_read (s
, s
->buffer
, s
->buffer_size
);
600 if (likely (did_read
>= 0))
602 s
->physical_offset
+= did_read
;
603 s
->active
= did_read
;
604 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
605 memcpy (p
, s
->buffer
, did_read
);
612 did_read
= raw_read (s
, p
, to_read
);
613 if (likely (did_read
>= 0))
615 s
->physical_offset
+= did_read
;
621 nbyte
= did_read
+ nread
;
623 s
->logical_offset
+= nbyte
;
628 buf_write (unix_stream
*s
, const void *buf
, ssize_t nbyte
)
634 s
->buffer_offset
= s
->logical_offset
;
636 /* Does the data fit into the buffer? As a special case, if the
637 buffer is empty and the request is bigger than s->buffer_size/2,
638 write directly. This avoids the case where the buffer would have
639 to be flushed at every write. */
640 if (!(s
->ndirty
== 0 && nbyte
> s
->buffer_size
/2)
641 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->buffer_size
642 && s
->buffer_offset
<= s
->logical_offset
643 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
645 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
646 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
652 /* Flush, and either fill the buffer with the new data, or if
653 the request is bigger than the buffer size, write directly
654 bypassing the buffer. */
656 if (nbyte
<= s
->buffer_size
/2)
658 memcpy (s
->buffer
, buf
, nbyte
);
659 s
->buffer_offset
= s
->logical_offset
;
664 if (s
->physical_offset
!= s
->logical_offset
)
666 if (raw_seek (s
, s
->logical_offset
, SEEK_SET
) < 0)
668 s
->physical_offset
= s
->logical_offset
;
671 nbyte
= raw_write (s
, buf
, nbyte
);
672 s
->physical_offset
+= nbyte
;
675 s
->logical_offset
+= nbyte
;
676 if (s
->logical_offset
> s
->file_length
)
677 s
->file_length
= s
->logical_offset
;
682 /* "Unbuffered" really means I/O statement buffering. For formatted
683 I/O, the fbuf manages this, and then uses raw I/O. For unformatted
684 I/O, buffered I/O is used, and the buffer is flushed at the end of
685 each I/O statement, where this function is called. Alternatively,
686 the buffer is flushed at the end of the record if the buffer is
687 more than half full; this prevents needless seeking back and forth
688 when writing sequential unformatted. */
691 buf_markeor (unix_stream
*s
)
693 if (s
->unbuffered
|| s
->ndirty
>= s
->buffer_size
/ 2)
694 return buf_flush (s
);
699 buf_seek (unix_stream
*s
, gfc_offset offset
, int whence
)
706 offset
+= s
->logical_offset
;
709 offset
+= s
->file_length
;
719 s
->logical_offset
= offset
;
724 buf_tell (unix_stream
*s
)
726 return buf_seek (s
, 0, SEEK_CUR
);
730 buf_size (unix_stream
*s
)
732 return s
->file_length
;
736 buf_truncate (unix_stream
*s
, gfc_offset length
)
740 if (buf_flush (s
) != 0)
742 r
= raw_truncate (s
, length
);
744 s
->file_length
= length
;
749 buf_close (unix_stream
*s
)
751 if (buf_flush (s
) != 0)
754 return raw_close (s
);
757 static const struct stream_vtable buf_vtable
= {
758 .read
= (void *) buf_read
,
759 .write
= (void *) buf_write
,
760 .seek
= (void *) buf_seek
,
761 .tell
= (void *) buf_tell
,
762 .size
= (void *) buf_size
,
763 .trunc
= (void *) buf_truncate
,
764 .close
= (void *) buf_close
,
765 .flush
= (void *) buf_flush
,
766 .markeor
= (void *) buf_markeor
770 buf_init (unix_stream
*s
, bool unformatted
)
772 s
->st
.vptr
= &buf_vtable
;
774 /* Try to guess a good value for the buffer size. For formatted
775 I/O, we use so many CPU cycles converting the data that there is
776 more sense in converving memory and especially cache. For
777 unformatted, a bigger block can have a large impact in some
782 if (options
.unformatted_buffer_size
> 0)
783 s
->buffer_size
= options
.unformatted_buffer_size
;
785 s
->buffer_size
= UNFORMATTED_BUFFER_SIZE_DEFAULT
;
789 if (options
.formatted_buffer_size
> 0)
790 s
->buffer_size
= options
.formatted_buffer_size
;
792 s
->buffer_size
= FORMATTED_BUFFER_SIZE_DEFAULT
;
795 s
->buffer
= xmalloc (s
->buffer_size
);
800 /*********************************************************************
801 memory stream functions - These are used for internal files
803 The idea here is that a single stream structure is created and all
804 requests must be satisfied from it. The location and size of the
805 buffer is the character variable supplied to the READ or WRITE
808 *********************************************************************/
811 mem_alloc_r (stream
*strm
, size_t *len
)
813 unix_stream
*s
= (unix_stream
*) strm
;
815 gfc_offset where
= s
->logical_offset
;
817 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
820 n
= s
->buffer_offset
+ s
->active
- where
;
821 if ((gfc_offset
) *len
> n
)
824 s
->logical_offset
= where
+ *len
;
826 return s
->buffer
+ (where
- s
->buffer_offset
);
831 mem_alloc_r4 (stream
*strm
, size_t *len
)
833 unix_stream
*s
= (unix_stream
*) strm
;
835 gfc_offset where
= s
->logical_offset
;
837 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
840 n
= s
->buffer_offset
+ s
->active
- where
;
841 if ((gfc_offset
) *len
> n
)
844 s
->logical_offset
= where
+ *len
;
846 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
851 mem_alloc_w (stream
*strm
, size_t *len
)
853 unix_stream
*s
= (unix_stream
*)strm
;
855 gfc_offset where
= s
->logical_offset
;
859 if (where
< s
->buffer_offset
)
862 if (m
> s
->file_length
)
865 s
->logical_offset
= m
;
867 return s
->buffer
+ (where
- s
->buffer_offset
);
872 mem_alloc_w4 (stream
*strm
, size_t *len
)
874 unix_stream
*s
= (unix_stream
*)strm
;
876 gfc_offset where
= s
->logical_offset
;
877 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
881 if (where
< s
->buffer_offset
)
884 if (m
> s
->file_length
)
887 s
->logical_offset
= m
;
888 return &result
[where
- s
->buffer_offset
];
892 /* Stream read function for character(kind=1) internal units. */
895 mem_read (stream
*s
, void *buf
, ssize_t nbytes
)
900 p
= mem_alloc_r (s
, &nb
);
911 /* Stream read function for chracter(kind=4) internal units. */
914 mem_read4 (stream
*s
, void *buf
, ssize_t nbytes
)
919 p
= mem_alloc_r4 (s
, &nb
);
922 memcpy (buf
, p
, nb
* 4);
930 /* Stream write function for character(kind=1) internal units. */
933 mem_write (stream
*s
, const void *buf
, ssize_t nbytes
)
938 p
= mem_alloc_w (s
, &nb
);
949 /* Stream write function for character(kind=4) internal units. */
952 mem_write4 (stream
*s
, const void *buf
, ssize_t nwords
)
957 p
= mem_alloc_w4 (s
, &nw
);
961 *p
++ = (gfc_char4_t
) *((char *) buf
);
970 mem_seek (stream
*strm
, gfc_offset offset
, int whence
)
972 unix_stream
*s
= (unix_stream
*)strm
;
978 offset
+= s
->logical_offset
;
981 offset
+= s
->file_length
;
987 /* Note that for internal array I/O it's actually possible to have a
988 negative offset, so don't check for that. */
989 if (offset
> s
->file_length
)
995 s
->logical_offset
= offset
;
997 /* Returning < 0 is the error indicator for sseek(), so return 0 if
998 offset is negative. Thus if the return value is 0, the caller
999 has to use stell() to get the real value of logical_offset. */
1007 mem_tell (stream
*s
)
1009 return ((unix_stream
*)s
)->logical_offset
;
1014 mem_truncate (unix_stream
*s
__attribute__ ((unused
)),
1015 gfc_offset length
__attribute__ ((unused
)))
1022 mem_flush (unix_stream
*s
__attribute__ ((unused
)))
1029 mem_close (unix_stream
*s
)
1036 static const struct stream_vtable mem_vtable
= {
1037 .read
= (void *) mem_read
,
1038 .write
= (void *) mem_write
,
1039 .seek
= (void *) mem_seek
,
1040 .tell
= (void *) mem_tell
,
1041 /* buf_size is not a typo, we just reuse an identical
1043 .size
= (void *) buf_size
,
1044 .trunc
= (void *) mem_truncate
,
1045 .close
= (void *) mem_close
,
1046 .flush
= (void *) mem_flush
,
1047 .markeor
= (void *) raw_markeor
1050 static const struct stream_vtable mem4_vtable
= {
1051 .read
= (void *) mem_read4
,
1052 .write
= (void *) mem_write4
,
1053 .seek
= (void *) mem_seek
,
1054 .tell
= (void *) mem_tell
,
1055 /* buf_size is not a typo, we just reuse an identical
1057 .size
= (void *) buf_size
,
1058 .trunc
= (void *) mem_truncate
,
1059 .close
= (void *) mem_close
,
1060 .flush
= (void *) mem_flush
,
1061 .markeor
= (void *) raw_markeor
1064 /*********************************************************************
1065 Public functions -- A reimplementation of this module needs to
1066 define functional equivalents of the following.
1067 *********************************************************************/
1069 /* open_internal()-- Returns a stream structure from a character(kind=1)
1073 open_internal (char *base
, size_t length
, gfc_offset offset
)
1077 s
= xcalloc (1, sizeof (unix_stream
));
1080 s
->buffer_offset
= offset
;
1082 s
->active
= s
->file_length
= length
;
1084 s
->st
.vptr
= &mem_vtable
;
1086 return (stream
*) s
;
1089 /* open_internal4()-- Returns a stream structure from a character(kind=4)
1093 open_internal4 (char *base
, size_t length
, gfc_offset offset
)
1097 s
= xcalloc (1, sizeof (unix_stream
));
1100 s
->buffer_offset
= offset
;
1102 s
->active
= s
->file_length
= length
* sizeof (gfc_char4_t
);
1104 s
->st
.vptr
= &mem4_vtable
;
1110 /* fd_to_stream()-- Given an open file descriptor, build a stream
1114 fd_to_stream (int fd
, bool unformatted
)
1116 struct stat statbuf
;
1119 s
= xcalloc (1, sizeof (unix_stream
));
1123 /* Get the current length of the file. */
1125 if (TEMP_FAILURE_RETRY (fstat (fd
, &statbuf
)) == -1)
1127 s
->st_dev
= s
->st_ino
= -1;
1132 return (stream
*) s
;
1135 s
->st_dev
= statbuf
.st_dev
;
1136 s
->st_ino
= statbuf
.st_ino
;
1137 s
->file_length
= statbuf
.st_size
;
1139 /* Only use buffered IO for regular files. */
1140 if (S_ISREG (statbuf
.st_mode
)
1141 && !options
.all_unbuffered
1142 && !(options
.unbuffered_preconnected
&&
1143 (s
->fd
== STDIN_FILENO
1144 || s
->fd
== STDOUT_FILENO
1145 || s
->fd
== STDERR_FILENO
)))
1146 buf_init (s
, unformatted
);
1151 s
->unbuffered
= true;
1152 buf_init (s
, unformatted
);
1158 return (stream
*) s
;
1162 /* Given the Fortran unit number, convert it to a C file descriptor. */
1165 unit_to_fd (int unit
)
1170 us
= find_unit (unit
);
1174 fd
= ((unix_stream
*) us
->s
)->fd
;
1180 /* Set the close-on-exec flag for an existing fd, if the system
1183 static void __attribute__ ((unused
))
1184 set_close_on_exec (int fd
__attribute__ ((unused
)))
1186 /* Mingw does not define F_SETFD. */
1187 #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1189 fcntl(fd
, F_SETFD
, FD_CLOEXEC
);
1194 /* Helper function for tempfile(). Tries to open a temporary file in
1195 the directory specified by tempdir. If successful, the file name is
1196 stored in fname and the descriptor returned. Returns -1 on
1200 tempfile_open (const char *tempdir
, char **fname
)
1203 const char *slash
= "/";
1204 #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1211 /* Check for the special case that tempdir ends with a slash or
1213 size_t tempdirlen
= strlen (tempdir
);
1214 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1216 || tempdir
[tempdirlen
- 1] == '\\'
1221 /* Take care that the template is longer in the mktemp() branch. */
1222 char *template = xmalloc (tempdirlen
+ 23);
1225 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpXXXXXX",
1229 /* Temporarily set the umask such that the file has 0600 permissions. */
1230 mode_mask
= umask (S_IXUSR
| S_IRWXG
| S_IRWXO
);
1233 #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1234 TEMP_FAILURE_RETRY (fd
= mkostemp (template, O_CLOEXEC
));
1236 TEMP_FAILURE_RETRY (fd
= mkstemp (template));
1237 set_close_on_exec (fd
);
1241 (void) umask (mode_mask
);
1244 #else /* HAVE_MKSTEMP */
1247 size_t slashlen
= strlen (slash
);
1248 int flags
= O_RDWR
| O_CREAT
| O_EXCL
;
1249 #if defined(HAVE_CRLF) && defined(O_BINARY)
1257 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpaaaXXXXXX",
1262 template[tempdirlen
+ slashlen
+ 13] = 'a' + (c
% 26);
1264 template[tempdirlen
+ slashlen
+ 12] = 'a' + (c
% 26);
1266 template[tempdirlen
+ slashlen
+ 11] = 'a' + (c
% 26);
1271 if (!mktemp (template))
1278 TEMP_FAILURE_RETRY (fd
= open (template, flags
, S_IRUSR
| S_IWUSR
));
1280 while (fd
== -1 && errno
== EEXIST
);
1282 set_close_on_exec (fd
);
1284 #endif /* HAVE_MKSTEMP */
1291 /* tempfile()-- Generate a temporary filename for a scratch file and
1292 open it. mkstemp() opens the file for reading and writing, but the
1293 library mode prevents anything that is not allowed. The descriptor
1294 is returned, which is -1 on error. The template is pointed to by
1295 opp->file, which is copied into the unit structure
1299 tempfile (st_parameter_open
*opp
)
1301 const char *tempdir
;
1305 tempdir
= secure_getenv ("TMPDIR");
1306 fd
= tempfile_open (tempdir
, &fname
);
1310 char buffer
[MAX_PATH
+ 1];
1312 ret
= GetTempPath (MAX_PATH
, buffer
);
1313 /* If we are not able to get a temp-directory, we use
1314 current directory. */
1315 if (ret
> MAX_PATH
|| !ret
)
1319 tempdir
= strdup (buffer
);
1320 fd
= tempfile_open (tempdir
, &fname
);
1322 #elif defined(__CYGWIN__)
1325 tempdir
= secure_getenv ("TMP");
1326 fd
= tempfile_open (tempdir
, &fname
);
1330 tempdir
= secure_getenv ("TEMP");
1331 fd
= tempfile_open (tempdir
, &fname
);
1335 fd
= tempfile_open (P_tmpdir
, &fname
);
1338 opp
->file_len
= strlen (fname
); /* Don't include trailing nul */
1344 /* regular_file2()-- Open a regular file.
1345 Change flags->action if it is ACTION_UNSPECIFIED on entry,
1346 unless an error occurs.
1347 Returns the descriptor, which is less than zero on error. */
1350 regular_file2 (const char *path
, st_parameter_open
*opp
, unit_flags
*flags
)
1354 int crflag
, crflag2
;
1358 if (opp
->file_len
== 7)
1360 if (strncmp (path
, "CONOUT$", 7) == 0
1361 || strncmp (path
, "CONERR$", 7) == 0)
1363 fd
= open ("/dev/conout", O_WRONLY
);
1364 flags
->action
= ACTION_WRITE
;
1369 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1371 fd
= open ("/dev/conin", O_RDONLY
);
1372 flags
->action
= ACTION_READ
;
1379 if (opp
->file_len
== 7)
1381 if (strncmp (path
, "CONOUT$", 7) == 0
1382 || strncmp (path
, "CONERR$", 7) == 0)
1384 fd
= open ("CONOUT$", O_WRONLY
);
1385 flags
->action
= ACTION_WRITE
;
1390 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1392 fd
= open ("CONIN$", O_RDONLY
);
1393 flags
->action
= ACTION_READ
;
1398 switch (flags
->action
)
1408 case ACTION_READWRITE
:
1409 case ACTION_UNSPECIFIED
:
1414 internal_error (&opp
->common
, "regular_file(): Bad action");
1417 switch (flags
->status
)
1420 crflag
= O_CREAT
| O_EXCL
;
1423 case STATUS_OLD
: /* open will fail if the file does not exist*/
1427 case STATUS_UNKNOWN
:
1428 if (rwflag
== O_RDONLY
)
1434 case STATUS_REPLACE
:
1435 crflag
= O_CREAT
| O_TRUNC
;
1439 /* Note: STATUS_SCRATCH is handled by tempfile () and should
1440 never be seen here. */
1441 internal_error (&opp
->common
, "regular_file(): Bad status");
1444 /* rwflag |= O_LARGEFILE; */
1446 #if defined(HAVE_CRLF) && defined(O_BINARY)
1451 crflag
|= O_CLOEXEC
;
1454 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1455 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag
, mode
));
1456 if (flags
->action
!= ACTION_UNSPECIFIED
)
1461 flags
->action
= ACTION_READWRITE
;
1464 if (errno
!= EACCES
&& errno
!= EPERM
&& errno
!= EROFS
)
1467 /* retry for read-only access */
1469 if (flags
->status
== STATUS_UNKNOWN
)
1470 crflag2
= crflag
& ~(O_CREAT
);
1473 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag2
, mode
));
1476 flags
->action
= ACTION_READ
;
1477 return fd
; /* success */
1480 if (errno
!= EACCES
&& errno
!= EPERM
&& errno
!= ENOENT
)
1481 return fd
; /* failure */
1483 /* retry for write-only access */
1485 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag
, mode
));
1488 flags
->action
= ACTION_WRITE
;
1489 return fd
; /* success */
1491 return fd
; /* failure */
1495 /* Lock the file, if necessary, based on SHARE flags. */
1497 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1499 open_share (st_parameter_open
*opp
, int fd
, unit_flags
*flags
)
1503 if (fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
|| fd
== STDIN_FILENO
)
1508 f
.l_whence
= SEEK_SET
;
1510 switch (flags
->share
)
1512 case SHARE_DENYNONE
:
1514 r
= fcntl (fd
, F_SETLK
, &f
);
1517 /* Must be writable to hold write lock. */
1518 if (flags
->action
== ACTION_READ
)
1520 generate_error (&opp
->common
, LIBERROR_BAD_ACTION
,
1521 "Cannot set write lock on file opened for READ");
1525 r
= fcntl (fd
, F_SETLK
, &f
);
1527 case SHARE_UNSPECIFIED
:
1536 open_share (st_parameter_open
*opp
__attribute__ ((unused
)),
1537 int fd
__attribute__ ((unused
)),
1538 unit_flags
*flags
__attribute__ ((unused
)))
1542 #endif /* defined(HAVE_FCNTL) ... */
1545 /* Wrapper around regular_file2, to make sure we free the path after
1549 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1551 char *path
= fc_strdup (opp
->file
, opp
->file_len
);
1552 int fd
= regular_file2 (path
, opp
, flags
);
1557 /* open_external()-- Open an external file, unix specific version.
1558 Change flags->action if it is ACTION_UNSPECIFIED on entry.
1559 Returns NULL on operating system error. */
1562 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1566 if (flags
->status
== STATUS_SCRATCH
)
1568 fd
= tempfile (opp
);
1569 if (flags
->action
== ACTION_UNSPECIFIED
)
1570 flags
->action
= flags
->readonly
? ACTION_READ
: ACTION_READWRITE
;
1572 #if HAVE_UNLINK_OPEN_FILE
1573 /* We can unlink scratch files now and it will go away when closed. */
1580 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1582 fd
= regular_file (opp
, flags
);
1584 set_close_on_exec (fd
);
1592 if (open_share (opp
, fd
, flags
) < 0)
1595 return fd_to_stream (fd
, flags
->form
== FORM_UNFORMATTED
);
1599 /* input_stream()-- Return a stream pointer to the default input stream.
1600 Called on initialization. */
1605 return fd_to_stream (STDIN_FILENO
, false);
1609 /* output_stream()-- Return a stream pointer to the default output stream.
1610 Called on initialization. */
1613 output_stream (void)
1617 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1618 setmode (STDOUT_FILENO
, O_BINARY
);
1621 s
= fd_to_stream (STDOUT_FILENO
, false);
1626 /* error_stream()-- Return a stream pointer to the default error stream.
1627 Called on initialization. */
1634 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1635 setmode (STDERR_FILENO
, O_BINARY
);
1638 s
= fd_to_stream (STDERR_FILENO
, false);
1643 /* compare_file_filename()-- Given an open stream and a fortran string
1644 that is a filename, figure out if the file is the same as the
1648 compare_file_filename (gfc_unit
*u
, const char *name
, gfc_charlen_type len
)
1652 #ifdef HAVE_WORKING_STAT
1660 char *path
= fc_strdup (name
, len
);
1662 /* If the filename doesn't exist, then there is no match with the
1665 if (TEMP_FAILURE_RETRY (stat (path
, &st
)) < 0)
1671 #ifdef HAVE_WORKING_STAT
1672 s
= (unix_stream
*) (u
->s
);
1673 ret
= (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1678 /* We try to match files by a unique ID. On some filesystems (network
1679 fs and FAT), we can't generate this unique ID, and will simply compare
1681 id1
= id_from_path (path
);
1682 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1690 ret
= (strcmp(path
, u
->filename
) == 0);
1700 #ifdef HAVE_WORKING_STAT
1701 # define FIND_FILE0_DECL struct stat *st
1702 # define FIND_FILE0_ARGS st
1704 # define FIND_FILE0_DECL uint64_t id, const char *path
1705 # define FIND_FILE0_ARGS id, path
1708 /* find_file0()-- Recursive work function for find_file() */
1711 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1714 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1721 #ifdef HAVE_WORKING_STAT
1724 unix_stream
*s
= (unix_stream
*) (u
->s
);
1725 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1730 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1737 if (u
->filename
&& strcmp (u
->filename
, path
) == 0)
1741 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1745 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1753 /* find_file()-- Take the current filename and see if there is a unit
1754 that has the file already open. Returns a pointer to the unit if so. */
1757 find_file (const char *file
, gfc_charlen_type file_len
)
1761 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1765 char *path
= fc_strdup (file
, file_len
);
1767 if (TEMP_FAILURE_RETRY (stat (path
, &st
[0])) < 0)
1773 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1774 id
= id_from_path (path
);
1779 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1783 if (! __gthread_mutex_trylock (&u
->lock
))
1785 /* assert (u->closed == 0); */
1786 UNLOCK (&unit_lock
);
1790 inc_waiting_locked (u
);
1792 UNLOCK (&unit_lock
);
1800 if (predec_waiting_locked (u
) == 0)
1805 dec_waiting_unlocked (u
);
1813 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1817 if (u
->unit_number
> min_unit
)
1819 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1823 if (u
->unit_number
>= min_unit
)
1825 if (__gthread_mutex_trylock (&u
->lock
))
1837 flush_all_units (void)
1845 u
= flush_all_units_1 (unit_root
, min_unit
);
1847 inc_waiting_locked (u
);
1848 UNLOCK (&unit_lock
);
1854 min_unit
= u
->unit_number
+ 1;
1861 (void) predec_waiting_locked (u
);
1867 if (predec_waiting_locked (u
) == 0)
1875 /* Unlock the unit if necessary, based on SHARE flags. */
1878 close_share (gfc_unit
*u
__attribute__ ((unused
)))
1881 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1882 unix_stream
*s
= (unix_stream
*) u
->s
;
1886 switch (u
->flags
.share
)
1889 case SHARE_DENYNONE
:
1890 if (fd
!= STDOUT_FILENO
&& fd
!= STDERR_FILENO
&& fd
!= STDIN_FILENO
)
1894 f
.l_whence
= SEEK_SET
;
1896 r
= fcntl (fd
, F_SETLK
, &f
);
1899 case SHARE_UNSPECIFIED
:
1909 /* file_exists()-- Returns nonzero if the current filename exists on
1913 file_exists (const char *file
, gfc_charlen_type file_len
)
1915 char *path
= fc_strdup (file
, file_len
);
1916 int res
= !(access (path
, F_OK
));
1922 /* file_size()-- Returns the size of the file. */
1925 file_size (const char *file
, gfc_charlen_type file_len
)
1927 char *path
= fc_strdup (file
, file_len
);
1928 struct stat statbuf
;
1930 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1934 return (GFC_IO_INT
) statbuf
.st_size
;
1937 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1939 /* inquire_sequential()-- Given a fortran string, determine if the
1940 file is suitable for sequential access. Returns a C-style
1944 inquire_sequential (const char *string
, gfc_charlen_type len
)
1946 struct stat statbuf
;
1951 char *path
= fc_strdup (string
, len
);
1953 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1958 if (S_ISREG (statbuf
.st_mode
) ||
1959 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1962 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1969 /* inquire_direct()-- Given a fortran string, determine if the file is
1970 suitable for direct access. Returns a C-style string. */
1973 inquire_direct (const char *string
, gfc_charlen_type len
)
1975 struct stat statbuf
;
1980 char *path
= fc_strdup (string
, len
);
1982 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1987 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1990 if (S_ISDIR (statbuf
.st_mode
) ||
1991 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1998 /* inquire_formatted()-- Given a fortran string, determine if the file
1999 is suitable for formatted form. Returns a C-style string. */
2002 inquire_formatted (const char *string
, gfc_charlen_type len
)
2004 struct stat statbuf
;
2009 char *path
= fc_strdup (string
, len
);
2011 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
2016 if (S_ISREG (statbuf
.st_mode
) ||
2017 S_ISBLK (statbuf
.st_mode
) ||
2018 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
2021 if (S_ISDIR (statbuf
.st_mode
))
2028 /* inquire_unformatted()-- Given a fortran string, determine if the file
2029 is suitable for unformatted form. Returns a C-style string. */
2032 inquire_unformatted (const char *string
, gfc_charlen_type len
)
2034 return inquire_formatted (string
, len
);
2038 /* inquire_access()-- Given a fortran string, determine if the file is
2039 suitable for access. */
2042 inquire_access (const char *string
, gfc_charlen_type len
, int mode
)
2046 char *path
= fc_strdup (string
, len
);
2047 int res
= access (path
, mode
);
2056 /* inquire_read()-- Given a fortran string, determine if the file is
2057 suitable for READ access. */
2060 inquire_read (const char *string
, gfc_charlen_type len
)
2062 return inquire_access (string
, len
, R_OK
);
2066 /* inquire_write()-- Given a fortran string, determine if the file is
2067 suitable for READ access. */
2070 inquire_write (const char *string
, gfc_charlen_type len
)
2072 return inquire_access (string
, len
, W_OK
);
2076 /* inquire_readwrite()-- Given a fortran string, determine if the file is
2077 suitable for read and write access. */
2080 inquire_readwrite (const char *string
, gfc_charlen_type len
)
2082 return inquire_access (string
, len
, R_OK
| W_OK
);
2087 stream_isatty (stream
*s
)
2089 return isatty (((unix_stream
*) s
)->fd
);
2093 stream_ttyname (stream
*s
__attribute__ ((unused
)),
2094 char *buf
__attribute__ ((unused
)),
2095 size_t buflen
__attribute__ ((unused
)))
2097 #ifdef HAVE_TTYNAME_R
2098 return ttyname_r (((unix_stream
*)s
)->fd
, buf
, buflen
);
2099 #elif defined HAVE_TTYNAME
2102 p
= ttyname (((unix_stream
*)s
)->fd
);
2108 memcpy (buf
, p
, plen
);
2118 /* How files are stored: This is an operating-system specific issue,
2119 and therefore belongs here. There are three cases to consider.
2122 Records are written as block of bytes corresponding to the record
2123 length of the file. This goes for both formatted and unformatted
2124 records. Positioning is done explicitly for each data transfer,
2125 so positioning is not much of an issue.
2127 Sequential Formatted:
2128 Records are separated by newline characters. The newline character
2129 is prohibited from appearing in a string. If it does, this will be
2130 messed up on the next read. End of file is also the end of a record.
2132 Sequential Unformatted:
2133 In this case, we are merely copying bytes to and from main storage,
2134 yet we need to keep track of varying record lengths. We adopt
2135 the solution used by f2c. Each record contains a pair of length
2138 Length of record n in bytes
2140 Length of record n in bytes
2142 Length of record n+1 in bytes
2144 Length of record n+1 in bytes
2146 The length is stored at the end of a record to allow backspacing to the
2147 previous record. Between data transfer statements, the file pointer
2148 is left pointing to the first length of the current record.
2150 ENDFILE records are never explicitly stored.