1 /* Copyright (C) 2002-2023 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
)
1035 static const struct stream_vtable mem_vtable
= {
1036 .read
= (void *) mem_read
,
1037 .write
= (void *) mem_write
,
1038 .seek
= (void *) mem_seek
,
1039 .tell
= (void *) mem_tell
,
1040 /* buf_size is not a typo, we just reuse an identical
1042 .size
= (void *) buf_size
,
1043 .trunc
= (void *) mem_truncate
,
1044 .close
= (void *) mem_close
,
1045 .flush
= (void *) mem_flush
,
1046 .markeor
= (void *) raw_markeor
1049 static const struct stream_vtable mem4_vtable
= {
1050 .read
= (void *) mem_read4
,
1051 .write
= (void *) mem_write4
,
1052 .seek
= (void *) mem_seek
,
1053 .tell
= (void *) mem_tell
,
1054 /* buf_size is not a typo, we just reuse an identical
1056 .size
= (void *) buf_size
,
1057 .trunc
= (void *) mem_truncate
,
1058 .close
= (void *) mem_close
,
1059 .flush
= (void *) mem_flush
,
1060 .markeor
= (void *) raw_markeor
1063 /*********************************************************************
1064 Public functions -- A reimplementation of this module needs to
1065 define functional equivalents of the following.
1066 *********************************************************************/
1068 /* open_internal()-- Returns a stream structure from a character(kind=1)
1072 open_internal (char *base
, size_t length
, gfc_offset offset
)
1076 s
= xcalloc (1, sizeof (unix_stream
));
1079 s
->buffer_offset
= offset
;
1081 s
->active
= s
->file_length
= length
;
1083 s
->st
.vptr
= &mem_vtable
;
1085 return (stream
*) s
;
1088 /* open_internal4()-- Returns a stream structure from a character(kind=4)
1092 open_internal4 (char *base
, size_t length
, gfc_offset offset
)
1096 s
= xcalloc (1, sizeof (unix_stream
));
1099 s
->buffer_offset
= offset
;
1101 s
->active
= s
->file_length
= length
* sizeof (gfc_char4_t
);
1103 s
->st
.vptr
= &mem4_vtable
;
1109 /* fd_to_stream()-- Given an open file descriptor, build a stream
1113 fd_to_stream (int fd
, bool unformatted
)
1115 struct stat statbuf
;
1118 s
= xcalloc (1, sizeof (unix_stream
));
1122 /* Get the current length of the file. */
1124 if (TEMP_FAILURE_RETRY (fstat (fd
, &statbuf
)) == -1)
1126 s
->st_dev
= s
->st_ino
= -1;
1131 return (stream
*) s
;
1134 s
->st_dev
= statbuf
.st_dev
;
1135 s
->st_ino
= statbuf
.st_ino
;
1136 s
->file_length
= statbuf
.st_size
;
1138 /* Only use buffered IO for regular files. */
1139 if (S_ISREG (statbuf
.st_mode
)
1140 && !options
.all_unbuffered
1141 && !(options
.unbuffered_preconnected
&&
1142 (s
->fd
== STDIN_FILENO
1143 || s
->fd
== STDOUT_FILENO
1144 || s
->fd
== STDERR_FILENO
)))
1145 buf_init (s
, unformatted
);
1150 s
->unbuffered
= true;
1151 buf_init (s
, unformatted
);
1157 return (stream
*) s
;
1161 /* Given the Fortran unit number, convert it to a C file descriptor. */
1164 unit_to_fd (int unit
)
1169 us
= find_unit (unit
);
1173 fd
= ((unix_stream
*) us
->s
)->fd
;
1179 /* Set the close-on-exec flag for an existing fd, if the system
1182 static void __attribute__ ((unused
))
1183 set_close_on_exec (int fd
__attribute__ ((unused
)))
1185 /* Mingw does not define F_SETFD. */
1186 #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1188 fcntl(fd
, F_SETFD
, FD_CLOEXEC
);
1193 /* Helper function for tempfile(). Tries to open a temporary file in
1194 the directory specified by tempdir. If successful, the file name is
1195 stored in fname and the descriptor returned. Returns -1 on
1199 tempfile_open (const char *tempdir
, char **fname
)
1202 const char *slash
= "/";
1203 #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1210 /* Check for the special case that tempdir ends with a slash or
1212 size_t tempdirlen
= strlen (tempdir
);
1213 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1215 || tempdir
[tempdirlen
- 1] == '\\'
1220 /* Take care that the template is longer in the mktemp() branch. */
1221 char *template = xmalloc (tempdirlen
+ 23);
1224 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpXXXXXX",
1228 /* Temporarily set the umask such that the file has 0600 permissions. */
1229 mode_mask
= umask (S_IXUSR
| S_IRWXG
| S_IRWXO
);
1232 #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1233 TEMP_FAILURE_RETRY (fd
= mkostemp (template, O_CLOEXEC
));
1235 TEMP_FAILURE_RETRY (fd
= mkstemp (template));
1236 set_close_on_exec (fd
);
1240 (void) umask (mode_mask
);
1243 #else /* HAVE_MKSTEMP */
1246 size_t slashlen
= strlen (slash
);
1247 int flags
= O_RDWR
| O_CREAT
| O_EXCL
;
1248 #if defined(HAVE_CRLF) && defined(O_BINARY)
1256 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpaaaXXXXXX",
1261 template[tempdirlen
+ slashlen
+ 13] = 'a' + (c
% 26);
1263 template[tempdirlen
+ slashlen
+ 12] = 'a' + (c
% 26);
1265 template[tempdirlen
+ slashlen
+ 11] = 'a' + (c
% 26);
1270 if (!mktemp (template))
1277 TEMP_FAILURE_RETRY (fd
= open (template, flags
, S_IRUSR
| S_IWUSR
));
1279 while (fd
== -1 && errno
== EEXIST
);
1281 set_close_on_exec (fd
);
1283 #endif /* HAVE_MKSTEMP */
1290 /* tempfile()-- Generate a temporary filename for a scratch file and
1291 open it. mkstemp() opens the file for reading and writing, but the
1292 library mode prevents anything that is not allowed. The descriptor
1293 is returned, which is -1 on error. The template is pointed to by
1294 opp->file, which is copied into the unit structure
1298 tempfile (st_parameter_open
*opp
)
1300 const char *tempdir
;
1304 tempdir
= secure_getenv ("TMPDIR");
1305 fd
= tempfile_open (tempdir
, &fname
);
1309 char buffer
[MAX_PATH
+ 1];
1311 ret
= GetTempPath (MAX_PATH
, buffer
);
1312 /* If we are not able to get a temp-directory, we use
1313 current directory. */
1314 if (ret
> MAX_PATH
|| !ret
)
1318 tempdir
= strdup (buffer
);
1319 fd
= tempfile_open (tempdir
, &fname
);
1321 #elif defined(__CYGWIN__)
1324 tempdir
= secure_getenv ("TMP");
1325 fd
= tempfile_open (tempdir
, &fname
);
1329 tempdir
= secure_getenv ("TEMP");
1330 fd
= tempfile_open (tempdir
, &fname
);
1334 fd
= tempfile_open (P_tmpdir
, &fname
);
1337 opp
->file_len
= strlen (fname
); /* Don't include trailing nul */
1343 /* regular_file2()-- Open a regular file.
1344 Change flags->action if it is ACTION_UNSPECIFIED on entry,
1345 unless an error occurs.
1346 Returns the descriptor, which is less than zero on error. */
1349 regular_file2 (const char *path
, st_parameter_open
*opp
, unit_flags
*flags
)
1353 int crflag
, crflag2
;
1357 if (opp
->file_len
== 7)
1359 if (strncmp (path
, "CONOUT$", 7) == 0
1360 || strncmp (path
, "CONERR$", 7) == 0)
1362 fd
= open ("/dev/conout", O_WRONLY
);
1363 flags
->action
= ACTION_WRITE
;
1368 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1370 fd
= open ("/dev/conin", O_RDONLY
);
1371 flags
->action
= ACTION_READ
;
1378 if (opp
->file_len
== 7)
1380 if (strncmp (path
, "CONOUT$", 7) == 0
1381 || strncmp (path
, "CONERR$", 7) == 0)
1383 fd
= open ("CONOUT$", O_WRONLY
);
1384 flags
->action
= ACTION_WRITE
;
1389 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1391 fd
= open ("CONIN$", O_RDONLY
);
1392 flags
->action
= ACTION_READ
;
1397 switch (flags
->action
)
1407 case ACTION_READWRITE
:
1408 case ACTION_UNSPECIFIED
:
1413 internal_error (&opp
->common
, "regular_file(): Bad action");
1416 switch (flags
->status
)
1419 crflag
= O_CREAT
| O_EXCL
;
1422 case STATUS_OLD
: /* open will fail if the file does not exist*/
1426 case STATUS_UNKNOWN
:
1427 if (rwflag
== O_RDONLY
)
1433 case STATUS_REPLACE
:
1434 crflag
= O_CREAT
| O_TRUNC
;
1438 /* Note: STATUS_SCRATCH is handled by tempfile () and should
1439 never be seen here. */
1440 internal_error (&opp
->common
, "regular_file(): Bad status");
1443 /* rwflag |= O_LARGEFILE; */
1445 #if defined(HAVE_CRLF) && defined(O_BINARY)
1450 crflag
|= O_CLOEXEC
;
1453 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1454 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag
, mode
));
1455 if (flags
->action
!= ACTION_UNSPECIFIED
)
1460 flags
->action
= ACTION_READWRITE
;
1463 if (errno
!= EACCES
&& errno
!= EPERM
&& errno
!= EROFS
)
1466 /* retry for read-only access */
1468 if (flags
->status
== STATUS_UNKNOWN
)
1469 crflag2
= crflag
& ~(O_CREAT
);
1472 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag2
, mode
));
1475 flags
->action
= ACTION_READ
;
1476 return fd
; /* success */
1479 if (errno
!= EACCES
&& errno
!= EPERM
&& errno
!= ENOENT
)
1480 return fd
; /* failure */
1482 /* retry for write-only access */
1484 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag
, mode
));
1487 flags
->action
= ACTION_WRITE
;
1488 return fd
; /* success */
1490 return fd
; /* failure */
1494 /* Lock the file, if necessary, based on SHARE flags. */
1496 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1498 open_share (st_parameter_open
*opp
, int fd
, unit_flags
*flags
)
1502 if (fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
|| fd
== STDIN_FILENO
)
1507 f
.l_whence
= SEEK_SET
;
1509 switch (flags
->share
)
1511 case SHARE_DENYNONE
:
1513 r
= fcntl (fd
, F_SETLK
, &f
);
1516 /* Must be writable to hold write lock. */
1517 if (flags
->action
== ACTION_READ
)
1519 generate_error (&opp
->common
, LIBERROR_BAD_ACTION
,
1520 "Cannot set write lock on file opened for READ");
1524 r
= fcntl (fd
, F_SETLK
, &f
);
1526 case SHARE_UNSPECIFIED
:
1535 open_share (st_parameter_open
*opp
__attribute__ ((unused
)),
1536 int fd
__attribute__ ((unused
)),
1537 unit_flags
*flags
__attribute__ ((unused
)))
1541 #endif /* defined(HAVE_FCNTL) ... */
1544 /* Wrapper around regular_file2, to make sure we free the path after
1548 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1550 char *path
= fc_strdup (opp
->file
, opp
->file_len
);
1551 int fd
= regular_file2 (path
, opp
, flags
);
1556 /* open_external()-- Open an external file, unix specific version.
1557 Change flags->action if it is ACTION_UNSPECIFIED on entry.
1558 Returns NULL on operating system error. */
1561 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1565 if (flags
->status
== STATUS_SCRATCH
)
1567 fd
= tempfile (opp
);
1568 if (flags
->action
== ACTION_UNSPECIFIED
)
1569 flags
->action
= flags
->readonly
? ACTION_READ
: ACTION_READWRITE
;
1571 #if HAVE_UNLINK_OPEN_FILE
1572 /* We can unlink scratch files now and it will go away when closed. */
1579 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1581 fd
= regular_file (opp
, flags
);
1583 set_close_on_exec (fd
);
1591 if (open_share (opp
, fd
, flags
) < 0)
1594 return fd_to_stream (fd
, flags
->form
== FORM_UNFORMATTED
);
1598 /* input_stream()-- Return a stream pointer to the default input stream.
1599 Called on initialization. */
1604 return fd_to_stream (STDIN_FILENO
, false);
1608 /* output_stream()-- Return a stream pointer to the default output stream.
1609 Called on initialization. */
1612 output_stream (void)
1616 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1617 setmode (STDOUT_FILENO
, O_BINARY
);
1620 s
= fd_to_stream (STDOUT_FILENO
, false);
1625 /* error_stream()-- Return a stream pointer to the default error stream.
1626 Called on initialization. */
1633 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1634 setmode (STDERR_FILENO
, O_BINARY
);
1637 s
= fd_to_stream (STDERR_FILENO
, false);
1642 /* compare_file_filename()-- Given an open stream and a fortran string
1643 that is a filename, figure out if the file is the same as the
1647 compare_file_filename (gfc_unit
*u
, const char *name
, gfc_charlen_type len
)
1651 #ifdef HAVE_WORKING_STAT
1659 char *path
= fc_strdup (name
, len
);
1661 /* If the filename doesn't exist, then there is no match with the
1664 if (TEMP_FAILURE_RETRY (stat (path
, &st
)) < 0)
1670 #ifdef HAVE_WORKING_STAT
1671 s
= (unix_stream
*) (u
->s
);
1672 ret
= (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1677 /* We try to match files by a unique ID. On some filesystems (network
1678 fs and FAT), we can't generate this unique ID, and will simply compare
1680 id1
= id_from_path (path
);
1681 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1689 ret
= (strcmp(path
, u
->filename
) == 0);
1699 #ifdef HAVE_WORKING_STAT
1700 # define FIND_FILE0_DECL struct stat *st
1701 # define FIND_FILE0_ARGS st
1703 # define FIND_FILE0_DECL uint64_t id, const char *path
1704 # define FIND_FILE0_ARGS id, path
1707 /* find_file0()-- Recursive work function for find_file() */
1710 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1713 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1720 #ifdef HAVE_WORKING_STAT
1723 unix_stream
*s
= (unix_stream
*) (u
->s
);
1724 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1729 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1736 if (u
->filename
&& strcmp (u
->filename
, path
) == 0)
1740 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1744 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1752 /* find_file()-- Take the current filename and see if there is a unit
1753 that has the file already open. Returns a pointer to the unit if so. */
1756 find_file (const char *file
, gfc_charlen_type file_len
)
1760 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1764 char *path
= fc_strdup (file
, file_len
);
1766 if (TEMP_FAILURE_RETRY (stat (path
, &st
[0])) < 0)
1772 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1773 id
= id_from_path (path
);
1778 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1782 if (! __gthread_mutex_trylock (&u
->lock
))
1784 /* assert (u->closed == 0); */
1785 UNLOCK (&unit_lock
);
1789 inc_waiting_locked (u
);
1791 UNLOCK (&unit_lock
);
1799 if (predec_waiting_locked (u
) == 0)
1804 dec_waiting_unlocked (u
);
1812 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1816 if (u
->unit_number
> min_unit
)
1818 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1822 if (u
->unit_number
>= min_unit
)
1824 if (__gthread_mutex_trylock (&u
->lock
))
1836 flush_all_units (void)
1844 u
= flush_all_units_1 (unit_root
, min_unit
);
1846 inc_waiting_locked (u
);
1847 UNLOCK (&unit_lock
);
1853 min_unit
= u
->unit_number
+ 1;
1860 (void) predec_waiting_locked (u
);
1866 if (predec_waiting_locked (u
) == 0)
1874 /* Unlock the unit if necessary, based on SHARE flags. */
1877 close_share (gfc_unit
*u
__attribute__ ((unused
)))
1880 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1881 unix_stream
*s
= (unix_stream
*) u
->s
;
1885 switch (u
->flags
.share
)
1888 case SHARE_DENYNONE
:
1889 if (fd
!= STDOUT_FILENO
&& fd
!= STDERR_FILENO
&& fd
!= STDIN_FILENO
)
1893 f
.l_whence
= SEEK_SET
;
1895 r
= fcntl (fd
, F_SETLK
, &f
);
1898 case SHARE_UNSPECIFIED
:
1908 /* file_exists()-- Returns nonzero if the current filename exists on
1912 file_exists (const char *file
, gfc_charlen_type file_len
)
1914 char *path
= fc_strdup (file
, file_len
);
1915 int res
= !(access (path
, F_OK
));
1921 /* file_size()-- Returns the size of the file. */
1924 file_size (const char *file
, gfc_charlen_type file_len
)
1926 char *path
= fc_strdup (file
, file_len
);
1927 struct stat statbuf
;
1929 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1933 return (GFC_IO_INT
) statbuf
.st_size
;
1936 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1938 /* inquire_sequential()-- Given a fortran string, determine if the
1939 file is suitable for sequential access. Returns a C-style
1943 inquire_sequential (const char *string
, gfc_charlen_type len
)
1945 struct stat statbuf
;
1950 char *path
= fc_strdup (string
, len
);
1952 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1957 if (S_ISREG (statbuf
.st_mode
) ||
1958 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1961 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1968 /* inquire_direct()-- Given a fortran string, determine if the file is
1969 suitable for direct access. Returns a C-style string. */
1972 inquire_direct (const char *string
, gfc_charlen_type len
)
1974 struct stat statbuf
;
1979 char *path
= fc_strdup (string
, len
);
1981 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1986 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1989 if (S_ISDIR (statbuf
.st_mode
) ||
1990 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1997 /* inquire_formatted()-- Given a fortran string, determine if the file
1998 is suitable for formatted form. Returns a C-style string. */
2001 inquire_formatted (const char *string
, gfc_charlen_type len
)
2003 struct stat statbuf
;
2008 char *path
= fc_strdup (string
, len
);
2010 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
2015 if (S_ISREG (statbuf
.st_mode
) ||
2016 S_ISBLK (statbuf
.st_mode
) ||
2017 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
2020 if (S_ISDIR (statbuf
.st_mode
))
2027 /* inquire_unformatted()-- Given a fortran string, determine if the file
2028 is suitable for unformatted form. Returns a C-style string. */
2031 inquire_unformatted (const char *string
, gfc_charlen_type len
)
2033 return inquire_formatted (string
, len
);
2037 /* inquire_access()-- Given a fortran string, determine if the file is
2038 suitable for access. */
2041 inquire_access (const char *string
, gfc_charlen_type len
, int mode
)
2045 char *path
= fc_strdup (string
, len
);
2046 int res
= access (path
, mode
);
2055 /* inquire_read()-- Given a fortran string, determine if the file is
2056 suitable for READ access. */
2059 inquire_read (const char *string
, gfc_charlen_type len
)
2061 return inquire_access (string
, len
, R_OK
);
2065 /* inquire_write()-- Given a fortran string, determine if the file is
2066 suitable for READ access. */
2069 inquire_write (const char *string
, gfc_charlen_type len
)
2071 return inquire_access (string
, len
, W_OK
);
2075 /* inquire_readwrite()-- Given a fortran string, determine if the file is
2076 suitable for read and write access. */
2079 inquire_readwrite (const char *string
, gfc_charlen_type len
)
2081 return inquire_access (string
, len
, R_OK
| W_OK
);
2086 stream_isatty (stream
*s
)
2088 return isatty (((unix_stream
*) s
)->fd
);
2092 stream_ttyname (stream
*s
__attribute__ ((unused
)),
2093 char *buf
__attribute__ ((unused
)),
2094 size_t buflen
__attribute__ ((unused
)))
2096 #ifdef HAVE_TTYNAME_R
2097 return ttyname_r (((unix_stream
*)s
)->fd
, buf
, buflen
);
2098 #elif defined HAVE_TTYNAME
2101 p
= ttyname (((unix_stream
*)s
)->fd
);
2107 memcpy (buf
, p
, plen
);
2117 /* How files are stored: This is an operating-system specific issue,
2118 and therefore belongs here. There are three cases to consider.
2121 Records are written as block of bytes corresponding to the record
2122 length of the file. This goes for both formatted and unformatted
2123 records. Positioning is done explicitly for each data transfer,
2124 so positioning is not much of an issue.
2126 Sequential Formatted:
2127 Records are separated by newline characters. The newline character
2128 is prohibited from appearing in a string. If it does, this will be
2129 messed up on the next read. End of file is also the end of a record.
2131 Sequential Unformatted:
2132 In this case, we are merely copying bytes to and from main storage,
2133 yet we need to keep track of varying record lengths. We adopt
2134 the solution used by f2c. Each record contains a pair of length
2137 Length of record n in bytes
2139 Length of record n in bytes
2141 Length of record n+1 in bytes
2143 Length of record n+1 in bytes
2145 The length is stored at the end of a record to allow backspacing to the
2146 previous record. Between data transfer statements, the file pointer
2147 is left pointing to the first length of the current record.
2149 ENDFILE records are never explicitly stored.