1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
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)
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 */
44 /* min macro that evaluates its arguments only once. */
46 ({ typeof (a) _a = (a); \
47 typeof (b) _b = (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. */
55 #define WIN32_LEAN_AND_MEAN
58 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
60 #define lseek _lseeki64
62 #define fstat _fstati64
67 #ifndef HAVE_WORKING_STAT
69 id_from_handle (HANDLE hFile
)
71 BY_HANDLE_FILE_INFORMATION FileInformation
;
73 if (hFile
== INVALID_HANDLE_VALUE
)
76 memset (&FileInformation
, 0, sizeof(FileInformation
));
77 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
80 return ((uint64_t) FileInformation
.nFileIndexLow
)
81 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
86 id_from_path (const char *path
)
91 if (!path
|| !*path
|| access (path
, F_OK
))
94 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
95 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
97 res
= id_from_handle (hFile
);
104 id_from_fd (const int fd
)
106 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
113 #define PATH_MAX 1024
116 /* These flags aren't defined on all targets (mingw32), so provide them
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. */
153 fallback_access (const char *path
, int mode
)
157 if ((mode
& R_OK
) && (fd
= open (path
, O_RDONLY
)) < 0)
161 if ((mode
& W_OK
) && (fd
= open (path
, O_WRONLY
)) < 0)
168 return stat (path
, &st
);
175 #define access fallback_access
179 /* Unix and internal stream I/O module */
181 static const int BUFFER_SIZE
= 8192;
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. */
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 /* Cached stat(2) values. */
206 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
207 * standard descriptors, returning a non-standard descriptor. If the
208 * user specifies that system errors should go to standard output,
209 * then closes standard output, we don't want the system errors to a
210 * file that has been given file descriptor 1 or 0. We want to send
211 * the error to the invalid descriptor. */
217 int input
, output
, error
;
219 input
= output
= error
= 0;
221 /* Unix allocates the lowest descriptors first, so a loop is not
222 required, but this order is. */
223 if (fd
== STDIN_FILENO
)
228 if (fd
== STDOUT_FILENO
)
233 if (fd
== STDERR_FILENO
)
240 close (STDIN_FILENO
);
242 close (STDOUT_FILENO
);
244 close (STDERR_FILENO
);
251 /* If the stream corresponds to a preconnected unit, we flush the
252 corresponding C stream. This is bugware for mixed C-Fortran codes
253 where the C code doesn't flush I/O before returning. */
255 flush_if_preconnected (stream
* s
)
259 fd
= ((unix_stream
*) s
)->fd
;
260 if (fd
== STDIN_FILENO
)
262 else if (fd
== STDOUT_FILENO
)
264 else if (fd
== STDERR_FILENO
)
269 /********************************************************************
270 Raw I/O functions (read, write, seek, tell, truncate, close).
272 These functions wrap the basic POSIX I/O syscalls. Any deviation in
273 semantics is a bug, except the following: write restarts in case
274 of being interrupted by a signal, and as the first argument the
275 functions take the unix_stream struct rather than an integer file
276 descriptor. Also, for POSIX read() and write() a nbyte argument larger
277 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
278 than size_t as for POSIX read/write.
279 *********************************************************************/
282 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
288 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
290 /* For read we can't do I/O in a loop like raw_write does, because
291 that will break applications that wait for interactive I/O. */
292 return read (s
->fd
, buf
, nbyte
);
296 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
298 ssize_t trans
, bytes_left
;
302 buf_st
= (char *) buf
;
304 /* We must write in a loop since some systems don't restart system
305 calls in case of a signal. */
306 while (bytes_left
> 0)
308 trans
= write (s
->fd
, buf_st
, bytes_left
);
320 return nbyte
- bytes_left
;
324 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
326 return lseek (s
->fd
, offset
, whence
);
330 raw_tell (unix_stream
* s
)
332 return lseek (s
->fd
, 0, SEEK_CUR
);
336 raw_size (unix_stream
* s
)
339 int ret
= fstat (s
->fd
, &statbuf
);
342 return statbuf
.st_size
;
346 raw_truncate (unix_stream
* s
, gfc_offset length
)
357 h
= (HANDLE
) _get_osfhandle (s
->fd
);
358 if (h
== INVALID_HANDLE_VALUE
)
363 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
366 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
368 if (!SetEndOfFile (h
))
373 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
377 lseek (s
->fd
, cur
, SEEK_SET
);
379 #elif defined HAVE_FTRUNCATE
380 return ftruncate (s
->fd
, length
);
381 #elif defined HAVE_CHSIZE
382 return chsize (s
->fd
, length
);
384 runtime_error ("required ftruncate or chsize support not present");
390 raw_close (unix_stream
* s
)
394 if (s
->fd
!= STDOUT_FILENO
395 && s
->fd
!= STDERR_FILENO
396 && s
->fd
!= STDIN_FILENO
)
397 retval
= close (s
->fd
);
404 static const struct stream_vtable raw_vtable
= {
405 .read
= (void *) raw_read
,
406 .write
= (void *) raw_write
,
407 .seek
= (void *) raw_seek
,
408 .tell
= (void *) raw_tell
,
409 .size
= (void *) raw_size
,
410 .trunc
= (void *) raw_truncate
,
411 .close
= (void *) raw_close
,
412 .flush
= (void *) raw_flush
416 raw_init (unix_stream
* s
)
418 s
->st
.vptr
= &raw_vtable
;
425 /*********************************************************************
426 Buffered I/O functions. These functions have the same semantics as the
427 raw I/O functions above, except that they are buffered in order to
428 improve performance. The buffer must be flushed when switching from
429 reading to writing and vice versa. Only supported for regular files.
430 *********************************************************************/
433 buf_flush (unix_stream
* s
)
437 /* Flushing in read mode means discarding read bytes. */
443 if (s
->physical_offset
!= s
->buffer_offset
444 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
447 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
449 s
->physical_offset
= s
->buffer_offset
+ writelen
;
451 if (s
->physical_offset
> s
->file_length
)
452 s
->file_length
= s
->physical_offset
;
454 s
->ndirty
-= writelen
;
462 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
465 s
->buffer_offset
= s
->logical_offset
;
467 /* Is the data we want in the buffer? */
468 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
469 && s
->buffer_offset
<= s
->logical_offset
)
470 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
473 /* First copy the active bytes if applicable, then read the rest
474 either directly or filling the buffer. */
477 ssize_t to_read
, did_read
;
478 gfc_offset new_logical
;
481 if (s
->logical_offset
>= s
->buffer_offset
482 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
484 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
485 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
489 /* At this point we consider all bytes in the buffer discarded. */
490 to_read
= nbyte
- nread
;
491 new_logical
= s
->logical_offset
+ nread
;
492 if (s
->physical_offset
!= new_logical
493 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
495 s
->buffer_offset
= s
->physical_offset
= new_logical
;
496 if (to_read
<= BUFFER_SIZE
/2)
498 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
499 s
->physical_offset
+= did_read
;
500 s
->active
= did_read
;
501 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
502 memcpy (p
, s
->buffer
, did_read
);
506 did_read
= raw_read (s
, p
, to_read
);
507 s
->physical_offset
+= did_read
;
510 nbyte
= did_read
+ nread
;
512 s
->logical_offset
+= nbyte
;
517 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
520 s
->buffer_offset
= s
->logical_offset
;
522 /* Does the data fit into the buffer? As a special case, if the
523 buffer is empty and the request is bigger than BUFFER_SIZE/2,
524 write directly. This avoids the case where the buffer would have
525 to be flushed at every write. */
526 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
527 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
528 && s
->buffer_offset
<= s
->logical_offset
529 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
531 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
532 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
538 /* Flush, and either fill the buffer with the new data, or if
539 the request is bigger than the buffer size, write directly
540 bypassing the buffer. */
542 if (nbyte
<= BUFFER_SIZE
/2)
544 memcpy (s
->buffer
, buf
, nbyte
);
545 s
->buffer_offset
= s
->logical_offset
;
550 if (s
->physical_offset
!= s
->logical_offset
)
552 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
554 s
->physical_offset
= s
->logical_offset
;
557 nbyte
= raw_write (s
, buf
, nbyte
);
558 s
->physical_offset
+= nbyte
;
561 s
->logical_offset
+= nbyte
;
562 if (s
->logical_offset
> s
->file_length
)
563 s
->file_length
= s
->logical_offset
;
568 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
575 offset
+= s
->logical_offset
;
578 offset
+= s
->file_length
;
588 s
->logical_offset
= offset
;
593 buf_tell (unix_stream
* s
)
595 return buf_seek (s
, 0, SEEK_CUR
);
599 buf_size (unix_stream
* s
)
601 return s
->file_length
;
605 buf_truncate (unix_stream
* s
, gfc_offset length
)
609 if (buf_flush (s
) != 0)
611 r
= raw_truncate (s
, length
);
613 s
->file_length
= length
;
618 buf_close (unix_stream
* s
)
620 if (buf_flush (s
) != 0)
623 return raw_close (s
);
626 static const struct stream_vtable buf_vtable
= {
627 .read
= (void *) buf_read
,
628 .write
= (void *) buf_write
,
629 .seek
= (void *) buf_seek
,
630 .tell
= (void *) buf_tell
,
631 .size
= (void *) buf_size
,
632 .trunc
= (void *) buf_truncate
,
633 .close
= (void *) buf_close
,
634 .flush
= (void *) buf_flush
638 buf_init (unix_stream
* s
)
640 s
->st
.vptr
= &buf_vtable
;
642 s
->buffer
= get_mem (BUFFER_SIZE
);
647 /*********************************************************************
648 memory stream functions - These are used for internal files
650 The idea here is that a single stream structure is created and all
651 requests must be satisfied from it. The location and size of the
652 buffer is the character variable supplied to the READ or WRITE
655 *********************************************************************/
658 mem_alloc_r (stream
* strm
, int * len
)
660 unix_stream
* s
= (unix_stream
*) strm
;
662 gfc_offset where
= s
->logical_offset
;
664 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
667 n
= s
->buffer_offset
+ s
->active
- where
;
671 s
->logical_offset
= where
+ *len
;
673 return s
->buffer
+ (where
- s
->buffer_offset
);
678 mem_alloc_r4 (stream
* strm
, int * len
)
680 unix_stream
* s
= (unix_stream
*) strm
;
682 gfc_offset where
= s
->logical_offset
;
684 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
687 n
= s
->buffer_offset
+ s
->active
- where
;
691 s
->logical_offset
= where
+ *len
;
693 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
698 mem_alloc_w (stream
* strm
, int * len
)
700 unix_stream
* s
= (unix_stream
*) strm
;
702 gfc_offset where
= s
->logical_offset
;
706 if (where
< s
->buffer_offset
)
709 if (m
> s
->file_length
)
712 s
->logical_offset
= m
;
714 return s
->buffer
+ (where
- s
->buffer_offset
);
719 mem_alloc_w4 (stream
* strm
, int * len
)
721 unix_stream
* s
= (unix_stream
*) strm
;
723 gfc_offset where
= s
->logical_offset
;
724 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
728 if (where
< s
->buffer_offset
)
731 if (m
> s
->file_length
)
734 s
->logical_offset
= m
;
735 return &result
[where
- s
->buffer_offset
];
739 /* Stream read function for character(kine=1) internal units. */
742 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
747 p
= mem_alloc_r (s
, &nb
);
758 /* Stream read function for chracter(kind=4) internal units. */
761 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
766 p
= mem_alloc_r (s
, &nb
);
777 /* Stream write function for character(kind=1) internal units. */
780 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
785 p
= mem_alloc_w (s
, &nb
);
796 /* Stream write function for character(kind=4) internal units. */
799 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
804 p
= mem_alloc_w4 (s
, &nw
);
808 *p
++ = (gfc_char4_t
) *((char *) buf
);
817 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
819 unix_stream
* s
= (unix_stream
*) strm
;
825 offset
+= s
->logical_offset
;
828 offset
+= s
->file_length
;
834 /* Note that for internal array I/O it's actually possible to have a
835 negative offset, so don't check for that. */
836 if (offset
> s
->file_length
)
842 s
->logical_offset
= offset
;
844 /* Returning < 0 is the error indicator for sseek(), so return 0 if
845 offset is negative. Thus if the return value is 0, the caller
846 has to use stell() to get the real value of logical_offset. */
854 mem_tell (stream
* s
)
856 return ((unix_stream
*)s
)->logical_offset
;
861 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
862 gfc_offset length
__attribute__ ((unused
)))
869 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
876 mem_close (unix_stream
* s
)
883 static const struct stream_vtable mem_vtable
= {
884 .read
= (void *) mem_read
,
885 .write
= (void *) mem_write
,
886 .seek
= (void *) mem_seek
,
887 .tell
= (void *) mem_tell
,
888 /* buf_size is not a typo, we just reuse an identical
890 .size
= (void *) buf_size
,
891 .trunc
= (void *) mem_truncate
,
892 .close
= (void *) mem_close
,
893 .flush
= (void *) mem_flush
896 static const struct stream_vtable mem4_vtable
= {
897 .read
= (void *) mem_read4
,
898 .write
= (void *) mem_write4
,
899 .seek
= (void *) mem_seek
,
900 .tell
= (void *) mem_tell
,
901 /* buf_size is not a typo, we just reuse an identical
903 .size
= (void *) buf_size
,
904 .trunc
= (void *) mem_truncate
,
905 .close
= (void *) mem_close
,
906 .flush
= (void *) mem_flush
909 /*********************************************************************
910 Public functions -- A reimplementation of this module needs to
911 define functional equivalents of the following.
912 *********************************************************************/
914 /* open_internal()-- Returns a stream structure from a character(kind=1)
918 open_internal (char *base
, int length
, gfc_offset offset
)
922 s
= xcalloc (1, sizeof (unix_stream
));
925 s
->buffer_offset
= offset
;
927 s
->active
= s
->file_length
= length
;
929 s
->st
.vptr
= &mem_vtable
;
934 /* open_internal4()-- Returns a stream structure from a character(kind=4)
938 open_internal4 (char *base
, int length
, gfc_offset offset
)
942 s
= xcalloc (1, sizeof (unix_stream
));
945 s
->buffer_offset
= offset
;
947 s
->active
= s
->file_length
= length
;
949 s
->st
.vptr
= &mem4_vtable
;
955 /* fd_to_stream()-- Given an open file descriptor, build a stream
959 fd_to_stream (int fd
)
964 s
= xcalloc (1, sizeof (unix_stream
));
968 /* Get the current length of the file. */
970 fstat (fd
, &statbuf
);
972 s
->st_dev
= statbuf
.st_dev
;
973 s
->st_ino
= statbuf
.st_ino
;
974 s
->file_length
= statbuf
.st_size
;
976 /* Only use buffered IO for regular files. */
977 if (S_ISREG (statbuf
.st_mode
)
978 && !options
.all_unbuffered
979 && !(options
.unbuffered_preconnected
&&
980 (s
->fd
== STDIN_FILENO
981 || s
->fd
== STDOUT_FILENO
982 || s
->fd
== STDERR_FILENO
)))
991 /* Given the Fortran unit number, convert it to a C file descriptor. */
994 unit_to_fd (int unit
)
999 us
= find_unit (unit
);
1003 fd
= ((unix_stream
*) us
->s
)->fd
;
1009 /* unpack_filename()-- Given a fortran string and a pointer to a
1010 * buffer that is PATH_MAX characters, convert the fortran string to a
1011 * C string in the buffer. Returns nonzero if this is not possible. */
1014 unpack_filename (char *cstring
, const char *fstring
, int len
)
1016 if (fstring
== NULL
)
1018 len
= fstrlen (fstring
, len
);
1019 if (len
>= PATH_MAX
)
1020 return ENAMETOOLONG
;
1022 memmove (cstring
, fstring
, len
);
1023 cstring
[len
] = '\0';
1029 /* tempfile()-- Generate a temporary filename for a scratch file and
1030 * open it. mkstemp() opens the file for reading and writing, but the
1031 * library mode prevents anything that is not allowed. The descriptor
1032 * is returned, which is -1 on error. The template is pointed to by
1033 * opp->file, which is copied into the unit structure
1034 * and freed later. */
1037 tempfile (st_parameter_open
*opp
)
1039 const char *tempdir
;
1041 const char *slash
= "/";
1045 #ifndef HAVE_MKSTEMP
1050 tempdir
= getenv ("GFORTRAN_TMPDIR");
1052 if (tempdir
== NULL
)
1054 char buffer
[MAX_PATH
+ 1];
1056 ret
= GetTempPath (MAX_PATH
, buffer
);
1057 /* If we are not able to get a temp-directory, we use
1058 current directory. */
1059 if (ret
> MAX_PATH
|| !ret
)
1063 tempdir
= strdup (buffer
);
1066 if (tempdir
== NULL
)
1067 tempdir
= getenv ("TMP");
1068 if (tempdir
== NULL
)
1069 tempdir
= getenv ("TEMP");
1070 if (tempdir
== NULL
)
1071 tempdir
= DEFAULT_TEMPDIR
;
1074 /* Check for special case that tempdir contains slash
1075 or backslash at end. */
1076 tempdirlen
= strlen (tempdir
);
1077 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1079 || tempdir
[tempdirlen
- 1] == '\\'
1084 // Take care that the template is longer in the mktemp() branch.
1085 template = get_mem (tempdirlen
+ 23);
1088 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpXXXXXX",
1091 fd
= mkstemp (template);
1093 #else /* HAVE_MKSTEMP */
1096 slashlen
= strlen (slash
);
1099 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpaaaXXXXXX",
1104 template[tempdirlen
+ slashlen
+ 13] = 'a' + (c
% 26);
1106 template[tempdirlen
+ slashlen
+ 12] = 'a' + (c
% 26);
1108 template[tempdirlen
+ slashlen
+ 11] = 'a' + (c
% 26);
1113 if (!mktemp (template))
1120 #if defined(HAVE_CRLF) && defined(O_BINARY)
1121 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1124 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IRUSR
| S_IWUSR
);
1127 while (fd
== -1 && errno
== EEXIST
);
1128 #endif /* HAVE_MKSTEMP */
1130 opp
->file
= template;
1131 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1137 /* regular_file()-- Open a regular file.
1138 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1139 * unless an error occurs.
1140 * Returns the descriptor, which is less than zero on error. */
1143 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1145 char path
[min(PATH_MAX
, opp
->file_len
+ 1)];
1152 err
= unpack_filename (path
, opp
->file
, opp
->file_len
);
1155 errno
= err
; /* Fake an OS error */
1160 if (opp
->file_len
== 7)
1162 if (strncmp (path
, "CONOUT$", 7) == 0
1163 || strncmp (path
, "CONERR$", 7) == 0)
1165 fd
= open ("/dev/conout", O_WRONLY
);
1166 flags
->action
= ACTION_WRITE
;
1171 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1173 fd
= open ("/dev/conin", O_RDONLY
);
1174 flags
->action
= ACTION_READ
;
1181 if (opp
->file_len
== 7)
1183 if (strncmp (path
, "CONOUT$", 7) == 0
1184 || strncmp (path
, "CONERR$", 7) == 0)
1186 fd
= open ("CONOUT$", O_WRONLY
);
1187 flags
->action
= ACTION_WRITE
;
1192 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1194 fd
= open ("CONIN$", O_RDONLY
);
1195 flags
->action
= ACTION_READ
;
1202 switch (flags
->action
)
1212 case ACTION_READWRITE
:
1213 case ACTION_UNSPECIFIED
:
1218 internal_error (&opp
->common
, "regular_file(): Bad action");
1221 switch (flags
->status
)
1224 crflag
= O_CREAT
| O_EXCL
;
1227 case STATUS_OLD
: /* open will fail if the file does not exist*/
1231 case STATUS_UNKNOWN
:
1232 case STATUS_SCRATCH
:
1236 case STATUS_REPLACE
:
1237 crflag
= O_CREAT
| O_TRUNC
;
1241 internal_error (&opp
->common
, "regular_file(): Bad status");
1244 /* rwflag |= O_LARGEFILE; */
1246 #if defined(HAVE_CRLF) && defined(O_BINARY)
1250 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1251 fd
= open (path
, rwflag
| crflag
, mode
);
1252 if (flags
->action
!= ACTION_UNSPECIFIED
)
1257 flags
->action
= ACTION_READWRITE
;
1260 if (errno
!= EACCES
&& errno
!= EROFS
)
1263 /* retry for read-only access */
1265 fd
= open (path
, rwflag
| crflag
, mode
);
1268 flags
->action
= ACTION_READ
;
1269 return fd
; /* success */
1272 if (errno
!= EACCES
)
1273 return fd
; /* failure */
1275 /* retry for write-only access */
1277 fd
= open (path
, rwflag
| crflag
, mode
);
1280 flags
->action
= ACTION_WRITE
;
1281 return fd
; /* success */
1283 return fd
; /* failure */
1287 /* open_external()-- Open an external file, unix specific version.
1288 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1289 * Returns NULL on operating system error. */
1292 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1296 if (flags
->status
== STATUS_SCRATCH
)
1298 fd
= tempfile (opp
);
1299 if (flags
->action
== ACTION_UNSPECIFIED
)
1300 flags
->action
= ACTION_READWRITE
;
1302 #if HAVE_UNLINK_OPEN_FILE
1303 /* We can unlink scratch files now and it will go away when closed. */
1310 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1312 fd
= regular_file (opp
, flags
);
1319 return fd_to_stream (fd
);
1323 /* input_stream()-- Return a stream pointer to the default input stream.
1324 * Called on initialization. */
1329 return fd_to_stream (STDIN_FILENO
);
1333 /* output_stream()-- Return a stream pointer to the default output stream.
1334 * Called on initialization. */
1337 output_stream (void)
1341 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1342 setmode (STDOUT_FILENO
, O_BINARY
);
1345 s
= fd_to_stream (STDOUT_FILENO
);
1350 /* error_stream()-- Return a stream pointer to the default error stream.
1351 * Called on initialization. */
1358 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1359 setmode (STDERR_FILENO
, O_BINARY
);
1362 s
= fd_to_stream (STDERR_FILENO
);
1367 /* compare_file_filename()-- Given an open stream and a fortran string
1368 * that is a filename, figure out if the file is the same as the
1372 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1374 char path
[min(PATH_MAX
, len
+ 1)];
1376 #ifdef HAVE_WORKING_STAT
1384 if (unpack_filename (path
, name
, len
))
1385 return 0; /* Can't be the same */
1387 /* If the filename doesn't exist, then there is no match with the
1390 if (stat (path
, &st
) < 0)
1393 #ifdef HAVE_WORKING_STAT
1394 s
= (unix_stream
*) (u
->s
);
1395 return (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1399 /* We try to match files by a unique ID. On some filesystems (network
1400 fs and FAT), we can't generate this unique ID, and will simply compare
1402 id1
= id_from_path (path
);
1403 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1405 return (id1
== id2
);
1408 if (len
!= u
->file_len
)
1410 return (memcmp(path
, u
->file
, len
) == 0);
1415 #ifdef HAVE_WORKING_STAT
1416 # define FIND_FILE0_DECL struct stat *st
1417 # define FIND_FILE0_ARGS st
1419 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1420 # define FIND_FILE0_ARGS id, file, file_len
1423 /* find_file0()-- Recursive work function for find_file() */
1426 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1429 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1436 #ifdef HAVE_WORKING_STAT
1439 unix_stream
*s
= (unix_stream
*) (u
->s
);
1440 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1445 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1452 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1456 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1460 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1468 /* find_file()-- Take the current filename and see if there is a unit
1469 * that has the file already open. Returns a pointer to the unit if so. */
1472 find_file (const char *file
, gfc_charlen_type file_len
)
1474 char path
[min(PATH_MAX
, file_len
+ 1)];
1477 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1481 if (unpack_filename (path
, file
, file_len
))
1484 if (stat (path
, &st
[0]) < 0)
1487 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1488 id
= id_from_path (path
);
1491 __gthread_mutex_lock (&unit_lock
);
1493 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1497 if (! __gthread_mutex_trylock (&u
->lock
))
1499 /* assert (u->closed == 0); */
1500 __gthread_mutex_unlock (&unit_lock
);
1504 inc_waiting_locked (u
);
1506 __gthread_mutex_unlock (&unit_lock
);
1509 __gthread_mutex_lock (&u
->lock
);
1512 __gthread_mutex_lock (&unit_lock
);
1513 __gthread_mutex_unlock (&u
->lock
);
1514 if (predec_waiting_locked (u
) == 0)
1519 dec_waiting_unlocked (u
);
1525 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1529 if (u
->unit_number
> min_unit
)
1531 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1535 if (u
->unit_number
>= min_unit
)
1537 if (__gthread_mutex_trylock (&u
->lock
))
1541 __gthread_mutex_unlock (&u
->lock
);
1549 flush_all_units (void)
1554 __gthread_mutex_lock (&unit_lock
);
1557 u
= flush_all_units_1 (unit_root
, min_unit
);
1559 inc_waiting_locked (u
);
1560 __gthread_mutex_unlock (&unit_lock
);
1564 __gthread_mutex_lock (&u
->lock
);
1566 min_unit
= u
->unit_number
+ 1;
1571 __gthread_mutex_lock (&unit_lock
);
1572 __gthread_mutex_unlock (&u
->lock
);
1573 (void) predec_waiting_locked (u
);
1577 __gthread_mutex_lock (&unit_lock
);
1578 __gthread_mutex_unlock (&u
->lock
);
1579 if (predec_waiting_locked (u
) == 0)
1587 /* delete_file()-- Given a unit structure, delete the file associated
1588 * with the unit. Returns nonzero if something went wrong. */
1591 delete_file (gfc_unit
* u
)
1593 char path
[min(PATH_MAX
, u
->file_len
+ 1)];
1594 int err
= unpack_filename (path
, u
->file
, u
->file_len
);
1597 { /* Shouldn't be possible */
1602 return unlink (path
);
1606 /* file_exists()-- Returns nonzero if the current filename exists on
1610 file_exists (const char *file
, gfc_charlen_type file_len
)
1612 char path
[min(PATH_MAX
, file_len
+ 1)];
1614 if (unpack_filename (path
, file
, file_len
))
1617 return !(access (path
, F_OK
));
1621 /* file_size()-- Returns the size of the file. */
1624 file_size (const char *file
, gfc_charlen_type file_len
)
1626 char path
[min(PATH_MAX
, file_len
+ 1)];
1627 struct stat statbuf
;
1629 if (unpack_filename (path
, file
, file_len
))
1632 if (stat (path
, &statbuf
) < 0)
1635 return (GFC_IO_INT
) statbuf
.st_size
;
1638 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1640 /* inquire_sequential()-- Given a fortran string, determine if the
1641 * file is suitable for sequential access. Returns a C-style
1645 inquire_sequential (const char *string
, int len
)
1647 char path
[min(PATH_MAX
, len
+ 1)];
1648 struct stat statbuf
;
1650 if (string
== NULL
||
1651 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1654 if (S_ISREG (statbuf
.st_mode
) ||
1655 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1658 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1665 /* inquire_direct()-- Given a fortran string, determine if the file is
1666 * suitable for direct access. Returns a C-style string. */
1669 inquire_direct (const char *string
, int len
)
1671 char path
[min(PATH_MAX
, len
+ 1)];
1672 struct stat statbuf
;
1674 if (string
== NULL
||
1675 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1678 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1681 if (S_ISDIR (statbuf
.st_mode
) ||
1682 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1689 /* inquire_formatted()-- Given a fortran string, determine if the file
1690 * is suitable for formatted form. Returns a C-style string. */
1693 inquire_formatted (const char *string
, int len
)
1695 char path
[min(PATH_MAX
, len
+ 1)];
1696 struct stat statbuf
;
1698 if (string
== NULL
||
1699 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1702 if (S_ISREG (statbuf
.st_mode
) ||
1703 S_ISBLK (statbuf
.st_mode
) ||
1704 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1707 if (S_ISDIR (statbuf
.st_mode
))
1714 /* inquire_unformatted()-- Given a fortran string, determine if the file
1715 * is suitable for unformatted form. Returns a C-style string. */
1718 inquire_unformatted (const char *string
, int len
)
1720 return inquire_formatted (string
, len
);
1724 /* inquire_access()-- Given a fortran string, determine if the file is
1725 * suitable for access. */
1728 inquire_access (const char *string
, int len
, int mode
)
1730 char path
[min(PATH_MAX
, len
+ 1)];
1732 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1733 access (path
, mode
) < 0)
1740 /* inquire_read()-- Given a fortran string, determine if the file is
1741 * suitable for READ access. */
1744 inquire_read (const char *string
, int len
)
1746 return inquire_access (string
, len
, R_OK
);
1750 /* inquire_write()-- Given a fortran string, determine if the file is
1751 * suitable for READ access. */
1754 inquire_write (const char *string
, int len
)
1756 return inquire_access (string
, len
, W_OK
);
1760 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1761 * suitable for read and write access. */
1764 inquire_readwrite (const char *string
, int len
)
1766 return inquire_access (string
, len
, R_OK
| W_OK
);
1771 stream_isatty (stream
*s
)
1773 return isatty (((unix_stream
*) s
)->fd
);
1777 stream_ttyname (stream
*s
__attribute__ ((unused
)),
1778 char * buf
__attribute__ ((unused
)),
1779 size_t buflen
__attribute__ ((unused
)))
1781 #ifdef HAVE_TTYNAME_R
1782 return ttyname_r (((unix_stream
*) s
)->fd
, buf
, buflen
);
1783 #elif defined HAVE_TTYNAME
1786 p
= ttyname (((unix_stream
*) s
)->fd
);
1792 memcpy (buf
, p
, plen
);
1802 /* How files are stored: This is an operating-system specific issue,
1803 and therefore belongs here. There are three cases to consider.
1806 Records are written as block of bytes corresponding to the record
1807 length of the file. This goes for both formatted and unformatted
1808 records. Positioning is done explicitly for each data transfer,
1809 so positioning is not much of an issue.
1811 Sequential Formatted:
1812 Records are separated by newline characters. The newline character
1813 is prohibited from appearing in a string. If it does, this will be
1814 messed up on the next read. End of file is also the end of a record.
1816 Sequential Unformatted:
1817 In this case, we are merely copying bytes to and from main storage,
1818 yet we need to keep track of varying record lengths. We adopt
1819 the solution used by f2c. Each record contains a pair of length
1822 Length of record n in bytes
1824 Length of record n in bytes
1826 Length of record n+1 in bytes
1828 Length of record n+1 in bytes
1830 The length is stored at the end of a record to allow backspacing to the
1831 previous record. Between data transfer statements, the file pointer
1832 is left pointing to the first length of the current record.
1834 ENDFILE records are never explicitly stored.