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 /* Fallback directory for creating temporary files. P_tmpdir is
180 defined on many POSIX platforms. */
183 #define P_tmpdir _P_tmpdir /* MinGW */
185 #define P_tmpdir "/tmp"
190 /* Unix and internal stream I/O module */
192 static const int BUFFER_SIZE
= 8192;
198 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
199 gfc_offset physical_offset
; /* Current physical file offset */
200 gfc_offset logical_offset
; /* Current logical file offset */
201 gfc_offset file_length
; /* Length of the file. */
203 char *buffer
; /* Pointer to the buffer. */
204 int fd
; /* The POSIX file descriptor. */
206 int active
; /* Length of valid bytes in the buffer */
208 int ndirty
; /* Dirty bytes starting at buffer_offset */
210 /* Cached stat(2) values. */
217 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
218 * standard descriptors, returning a non-standard descriptor. If the
219 * user specifies that system errors should go to standard output,
220 * then closes standard output, we don't want the system errors to a
221 * file that has been given file descriptor 1 or 0. We want to send
222 * the error to the invalid descriptor. */
228 int input
, output
, error
;
230 input
= output
= error
= 0;
232 /* Unix allocates the lowest descriptors first, so a loop is not
233 required, but this order is. */
234 if (fd
== STDIN_FILENO
)
239 if (fd
== STDOUT_FILENO
)
244 if (fd
== STDERR_FILENO
)
251 close (STDIN_FILENO
);
253 close (STDOUT_FILENO
);
255 close (STDERR_FILENO
);
262 /* If the stream corresponds to a preconnected unit, we flush the
263 corresponding C stream. This is bugware for mixed C-Fortran codes
264 where the C code doesn't flush I/O before returning. */
266 flush_if_preconnected (stream
* s
)
270 fd
= ((unix_stream
*) s
)->fd
;
271 if (fd
== STDIN_FILENO
)
273 else if (fd
== STDOUT_FILENO
)
275 else if (fd
== STDERR_FILENO
)
280 /********************************************************************
281 Raw I/O functions (read, write, seek, tell, truncate, close).
283 These functions wrap the basic POSIX I/O syscalls. Any deviation in
284 semantics is a bug, except the following: write restarts in case
285 of being interrupted by a signal, and as the first argument the
286 functions take the unix_stream struct rather than an integer file
287 descriptor. Also, for POSIX read() and write() a nbyte argument larger
288 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
289 than size_t as for POSIX read/write.
290 *********************************************************************/
293 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
299 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
301 /* For read we can't do I/O in a loop like raw_write does, because
302 that will break applications that wait for interactive I/O. */
303 return read (s
->fd
, buf
, nbyte
);
307 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
309 ssize_t trans
, bytes_left
;
313 buf_st
= (char *) buf
;
315 /* We must write in a loop since some systems don't restart system
316 calls in case of a signal. */
317 while (bytes_left
> 0)
319 trans
= write (s
->fd
, buf_st
, bytes_left
);
331 return nbyte
- bytes_left
;
335 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
337 return lseek (s
->fd
, offset
, whence
);
341 raw_tell (unix_stream
* s
)
343 return lseek (s
->fd
, 0, SEEK_CUR
);
347 raw_size (unix_stream
* s
)
350 int ret
= fstat (s
->fd
, &statbuf
);
353 return statbuf
.st_size
;
357 raw_truncate (unix_stream
* s
, gfc_offset length
)
368 h
= (HANDLE
) _get_osfhandle (s
->fd
);
369 if (h
== INVALID_HANDLE_VALUE
)
374 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
377 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
379 if (!SetEndOfFile (h
))
384 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
388 lseek (s
->fd
, cur
, SEEK_SET
);
390 #elif defined HAVE_FTRUNCATE
391 return ftruncate (s
->fd
, length
);
392 #elif defined HAVE_CHSIZE
393 return chsize (s
->fd
, length
);
395 runtime_error ("required ftruncate or chsize support not present");
401 raw_close (unix_stream
* s
)
405 if (s
->fd
!= STDOUT_FILENO
406 && s
->fd
!= STDERR_FILENO
407 && s
->fd
!= STDIN_FILENO
)
408 retval
= close (s
->fd
);
415 static const struct stream_vtable raw_vtable
= {
416 .read
= (void *) raw_read
,
417 .write
= (void *) raw_write
,
418 .seek
= (void *) raw_seek
,
419 .tell
= (void *) raw_tell
,
420 .size
= (void *) raw_size
,
421 .trunc
= (void *) raw_truncate
,
422 .close
= (void *) raw_close
,
423 .flush
= (void *) raw_flush
427 raw_init (unix_stream
* s
)
429 s
->st
.vptr
= &raw_vtable
;
436 /*********************************************************************
437 Buffered I/O functions. These functions have the same semantics as the
438 raw I/O functions above, except that they are buffered in order to
439 improve performance. The buffer must be flushed when switching from
440 reading to writing and vice versa. Only supported for regular files.
441 *********************************************************************/
444 buf_flush (unix_stream
* s
)
448 /* Flushing in read mode means discarding read bytes. */
454 if (s
->physical_offset
!= s
->buffer_offset
455 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
458 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
460 s
->physical_offset
= s
->buffer_offset
+ writelen
;
462 if (s
->physical_offset
> s
->file_length
)
463 s
->file_length
= s
->physical_offset
;
465 s
->ndirty
-= writelen
;
473 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
476 s
->buffer_offset
= s
->logical_offset
;
478 /* Is the data we want in the buffer? */
479 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
480 && s
->buffer_offset
<= s
->logical_offset
)
481 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
484 /* First copy the active bytes if applicable, then read the rest
485 either directly or filling the buffer. */
488 ssize_t to_read
, did_read
;
489 gfc_offset new_logical
;
492 if (s
->logical_offset
>= s
->buffer_offset
493 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
495 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
496 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
500 /* At this point we consider all bytes in the buffer discarded. */
501 to_read
= nbyte
- nread
;
502 new_logical
= s
->logical_offset
+ nread
;
503 if (s
->physical_offset
!= new_logical
504 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
506 s
->buffer_offset
= s
->physical_offset
= new_logical
;
507 if (to_read
<= BUFFER_SIZE
/2)
509 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
510 s
->physical_offset
+= did_read
;
511 s
->active
= did_read
;
512 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
513 memcpy (p
, s
->buffer
, did_read
);
517 did_read
= raw_read (s
, p
, to_read
);
518 s
->physical_offset
+= did_read
;
521 nbyte
= did_read
+ nread
;
523 s
->logical_offset
+= nbyte
;
528 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
531 s
->buffer_offset
= s
->logical_offset
;
533 /* Does the data fit into the buffer? As a special case, if the
534 buffer is empty and the request is bigger than BUFFER_SIZE/2,
535 write directly. This avoids the case where the buffer would have
536 to be flushed at every write. */
537 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
538 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
539 && s
->buffer_offset
<= s
->logical_offset
540 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
542 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
543 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
549 /* Flush, and either fill the buffer with the new data, or if
550 the request is bigger than the buffer size, write directly
551 bypassing the buffer. */
553 if (nbyte
<= BUFFER_SIZE
/2)
555 memcpy (s
->buffer
, buf
, nbyte
);
556 s
->buffer_offset
= s
->logical_offset
;
561 if (s
->physical_offset
!= s
->logical_offset
)
563 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
565 s
->physical_offset
= s
->logical_offset
;
568 nbyte
= raw_write (s
, buf
, nbyte
);
569 s
->physical_offset
+= nbyte
;
572 s
->logical_offset
+= nbyte
;
573 if (s
->logical_offset
> s
->file_length
)
574 s
->file_length
= s
->logical_offset
;
579 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
586 offset
+= s
->logical_offset
;
589 offset
+= s
->file_length
;
599 s
->logical_offset
= offset
;
604 buf_tell (unix_stream
* s
)
606 return buf_seek (s
, 0, SEEK_CUR
);
610 buf_size (unix_stream
* s
)
612 return s
->file_length
;
616 buf_truncate (unix_stream
* s
, gfc_offset length
)
620 if (buf_flush (s
) != 0)
622 r
= raw_truncate (s
, length
);
624 s
->file_length
= length
;
629 buf_close (unix_stream
* s
)
631 if (buf_flush (s
) != 0)
634 return raw_close (s
);
637 static const struct stream_vtable buf_vtable
= {
638 .read
= (void *) buf_read
,
639 .write
= (void *) buf_write
,
640 .seek
= (void *) buf_seek
,
641 .tell
= (void *) buf_tell
,
642 .size
= (void *) buf_size
,
643 .trunc
= (void *) buf_truncate
,
644 .close
= (void *) buf_close
,
645 .flush
= (void *) buf_flush
649 buf_init (unix_stream
* s
)
651 s
->st
.vptr
= &buf_vtable
;
653 s
->buffer
= xmalloc (BUFFER_SIZE
);
658 /*********************************************************************
659 memory stream functions - These are used for internal files
661 The idea here is that a single stream structure is created and all
662 requests must be satisfied from it. The location and size of the
663 buffer is the character variable supplied to the READ or WRITE
666 *********************************************************************/
669 mem_alloc_r (stream
* strm
, int * len
)
671 unix_stream
* s
= (unix_stream
*) strm
;
673 gfc_offset where
= s
->logical_offset
;
675 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
678 n
= s
->buffer_offset
+ s
->active
- where
;
682 s
->logical_offset
= where
+ *len
;
684 return s
->buffer
+ (where
- s
->buffer_offset
);
689 mem_alloc_r4 (stream
* strm
, int * len
)
691 unix_stream
* s
= (unix_stream
*) strm
;
693 gfc_offset where
= s
->logical_offset
;
695 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
698 n
= s
->buffer_offset
+ s
->active
- where
;
702 s
->logical_offset
= where
+ *len
;
704 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
709 mem_alloc_w (stream
* strm
, int * len
)
711 unix_stream
* s
= (unix_stream
*) strm
;
713 gfc_offset where
= s
->logical_offset
;
717 if (where
< s
->buffer_offset
)
720 if (m
> s
->file_length
)
723 s
->logical_offset
= m
;
725 return s
->buffer
+ (where
- s
->buffer_offset
);
730 mem_alloc_w4 (stream
* strm
, int * len
)
732 unix_stream
* s
= (unix_stream
*) strm
;
734 gfc_offset where
= s
->logical_offset
;
735 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
739 if (where
< s
->buffer_offset
)
742 if (m
> s
->file_length
)
745 s
->logical_offset
= m
;
746 return &result
[where
- s
->buffer_offset
];
750 /* Stream read function for character(kind=1) internal units. */
753 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
758 p
= mem_alloc_r (s
, &nb
);
769 /* Stream read function for chracter(kind=4) internal units. */
772 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
777 p
= mem_alloc_r (s
, &nb
);
788 /* Stream write function for character(kind=1) internal units. */
791 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
796 p
= mem_alloc_w (s
, &nb
);
807 /* Stream write function for character(kind=4) internal units. */
810 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
815 p
= mem_alloc_w4 (s
, &nw
);
819 *p
++ = (gfc_char4_t
) *((char *) buf
);
828 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
830 unix_stream
* s
= (unix_stream
*) strm
;
836 offset
+= s
->logical_offset
;
839 offset
+= s
->file_length
;
845 /* Note that for internal array I/O it's actually possible to have a
846 negative offset, so don't check for that. */
847 if (offset
> s
->file_length
)
853 s
->logical_offset
= offset
;
855 /* Returning < 0 is the error indicator for sseek(), so return 0 if
856 offset is negative. Thus if the return value is 0, the caller
857 has to use stell() to get the real value of logical_offset. */
865 mem_tell (stream
* s
)
867 return ((unix_stream
*)s
)->logical_offset
;
872 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
873 gfc_offset length
__attribute__ ((unused
)))
880 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
887 mem_close (unix_stream
* s
)
894 static const struct stream_vtable mem_vtable
= {
895 .read
= (void *) mem_read
,
896 .write
= (void *) mem_write
,
897 .seek
= (void *) mem_seek
,
898 .tell
= (void *) mem_tell
,
899 /* buf_size is not a typo, we just reuse an identical
901 .size
= (void *) buf_size
,
902 .trunc
= (void *) mem_truncate
,
903 .close
= (void *) mem_close
,
904 .flush
= (void *) mem_flush
907 static const struct stream_vtable mem4_vtable
= {
908 .read
= (void *) mem_read4
,
909 .write
= (void *) mem_write4
,
910 .seek
= (void *) mem_seek
,
911 .tell
= (void *) mem_tell
,
912 /* buf_size is not a typo, we just reuse an identical
914 .size
= (void *) buf_size
,
915 .trunc
= (void *) mem_truncate
,
916 .close
= (void *) mem_close
,
917 .flush
= (void *) mem_flush
920 /*********************************************************************
921 Public functions -- A reimplementation of this module needs to
922 define functional equivalents of the following.
923 *********************************************************************/
925 /* open_internal()-- Returns a stream structure from a character(kind=1)
929 open_internal (char *base
, int length
, gfc_offset offset
)
933 s
= xcalloc (1, sizeof (unix_stream
));
936 s
->buffer_offset
= offset
;
938 s
->active
= s
->file_length
= length
;
940 s
->st
.vptr
= &mem_vtable
;
945 /* open_internal4()-- Returns a stream structure from a character(kind=4)
949 open_internal4 (char *base
, int length
, gfc_offset offset
)
953 s
= xcalloc (1, sizeof (unix_stream
));
956 s
->buffer_offset
= offset
;
958 s
->active
= s
->file_length
= length
;
960 s
->st
.vptr
= &mem4_vtable
;
966 /* fd_to_stream()-- Given an open file descriptor, build a stream
970 fd_to_stream (int fd
)
975 s
= xcalloc (1, sizeof (unix_stream
));
979 /* Get the current length of the file. */
981 fstat (fd
, &statbuf
);
983 s
->st_dev
= statbuf
.st_dev
;
984 s
->st_ino
= statbuf
.st_ino
;
985 s
->file_length
= statbuf
.st_size
;
987 /* Only use buffered IO for regular files. */
988 if (S_ISREG (statbuf
.st_mode
)
989 && !options
.all_unbuffered
990 && !(options
.unbuffered_preconnected
&&
991 (s
->fd
== STDIN_FILENO
992 || s
->fd
== STDOUT_FILENO
993 || s
->fd
== STDERR_FILENO
)))
1002 /* Given the Fortran unit number, convert it to a C file descriptor. */
1005 unit_to_fd (int unit
)
1010 us
= find_unit (unit
);
1014 fd
= ((unix_stream
*) us
->s
)->fd
;
1020 /* unpack_filename()-- Given a fortran string and a pointer to a
1021 * buffer that is PATH_MAX characters, convert the fortran string to a
1022 * C string in the buffer. Returns nonzero if this is not possible. */
1025 unpack_filename (char *cstring
, const char *fstring
, int len
)
1027 if (fstring
== NULL
)
1029 len
= fstrlen (fstring
, len
);
1030 if (len
>= PATH_MAX
)
1031 return ENAMETOOLONG
;
1033 memmove (cstring
, fstring
, len
);
1034 cstring
[len
] = '\0';
1040 /* Helper function for tempfile(). Tries to open a temporary file in
1041 the directory specified by tempdir. If successful, the file name is
1042 stored in fname and the descriptor returned. Returns -1 on
1046 tempfile_open (const char *tempdir
, char **fname
)
1049 const char *slash
= "/";
1054 /* Check for the special case that tempdir ends with a slash or
1056 size_t tempdirlen
= strlen (tempdir
);
1057 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1059 || tempdir
[tempdirlen
- 1] == '\\'
1064 // Take care that the template is longer in the mktemp() branch.
1065 char * template = xmalloc (tempdirlen
+ 23);
1068 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpXXXXXX",
1071 fd
= mkstemp (template);
1073 #else /* HAVE_MKSTEMP */
1076 size_t slashlen
= strlen (slash
);
1079 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpaaaXXXXXX",
1084 template[tempdirlen
+ slashlen
+ 13] = 'a' + (c
% 26);
1086 template[tempdirlen
+ slashlen
+ 12] = 'a' + (c
% 26);
1088 template[tempdirlen
+ slashlen
+ 11] = 'a' + (c
% 26);
1093 if (!mktemp (template))
1100 #if defined(HAVE_CRLF) && defined(O_BINARY)
1101 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1104 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IRUSR
| S_IWUSR
);
1107 while (fd
== -1 && errno
== EEXIST
);
1108 #endif /* HAVE_MKSTEMP */
1115 /* tempfile()-- Generate a temporary filename for a scratch file and
1116 * open it. mkstemp() opens the file for reading and writing, but the
1117 * library mode prevents anything that is not allowed. The descriptor
1118 * is returned, which is -1 on error. The template is pointed to by
1119 * opp->file, which is copied into the unit structure
1120 * and freed later. */
1123 tempfile (st_parameter_open
*opp
)
1125 const char *tempdir
;
1129 tempdir
= secure_getenv ("TMPDIR");
1130 fd
= tempfile_open (tempdir
, &fname
);
1134 char buffer
[MAX_PATH
+ 1];
1136 ret
= GetTempPath (MAX_PATH
, buffer
);
1137 /* If we are not able to get a temp-directory, we use
1138 current directory. */
1139 if (ret
> MAX_PATH
|| !ret
)
1143 tempdir
= strdup (buffer
);
1144 fd
= tempfile_open (tempdir
, &fname
);
1146 #elif defined(__CYGWIN__)
1149 tempdir
= secure_getenv ("TMP");
1150 fd
= tempfile_open (tempdir
, &fname
);
1154 tempdir
= secure_getenv ("TEMP");
1155 fd
= tempfile_open (tempdir
, &fname
);
1159 fd
= tempfile_open (P_tmpdir
, &fname
);
1162 opp
->file_len
= strlen (fname
); /* Don't include trailing nul */
1168 /* regular_file()-- Open a regular file.
1169 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1170 * unless an error occurs.
1171 * Returns the descriptor, which is less than zero on error. */
1174 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1176 char path
[min(PATH_MAX
, opp
->file_len
+ 1)];
1183 err
= unpack_filename (path
, opp
->file
, opp
->file_len
);
1186 errno
= err
; /* Fake an OS error */
1191 if (opp
->file_len
== 7)
1193 if (strncmp (path
, "CONOUT$", 7) == 0
1194 || strncmp (path
, "CONERR$", 7) == 0)
1196 fd
= open ("/dev/conout", O_WRONLY
);
1197 flags
->action
= ACTION_WRITE
;
1202 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1204 fd
= open ("/dev/conin", O_RDONLY
);
1205 flags
->action
= ACTION_READ
;
1212 if (opp
->file_len
== 7)
1214 if (strncmp (path
, "CONOUT$", 7) == 0
1215 || strncmp (path
, "CONERR$", 7) == 0)
1217 fd
= open ("CONOUT$", O_WRONLY
);
1218 flags
->action
= ACTION_WRITE
;
1223 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1225 fd
= open ("CONIN$", O_RDONLY
);
1226 flags
->action
= ACTION_READ
;
1233 switch (flags
->action
)
1243 case ACTION_READWRITE
:
1244 case ACTION_UNSPECIFIED
:
1249 internal_error (&opp
->common
, "regular_file(): Bad action");
1252 switch (flags
->status
)
1255 crflag
= O_CREAT
| O_EXCL
;
1258 case STATUS_OLD
: /* open will fail if the file does not exist*/
1262 case STATUS_UNKNOWN
:
1263 case STATUS_SCRATCH
:
1267 case STATUS_REPLACE
:
1268 crflag
= O_CREAT
| O_TRUNC
;
1272 internal_error (&opp
->common
, "regular_file(): Bad status");
1275 /* rwflag |= O_LARGEFILE; */
1277 #if defined(HAVE_CRLF) && defined(O_BINARY)
1281 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1282 fd
= open (path
, rwflag
| crflag
, mode
);
1283 if (flags
->action
!= ACTION_UNSPECIFIED
)
1288 flags
->action
= ACTION_READWRITE
;
1291 if (errno
!= EACCES
&& errno
!= EROFS
)
1294 /* retry for read-only access */
1296 fd
= open (path
, rwflag
| crflag
, mode
);
1299 flags
->action
= ACTION_READ
;
1300 return fd
; /* success */
1303 if (errno
!= EACCES
)
1304 return fd
; /* failure */
1306 /* retry for write-only access */
1308 fd
= open (path
, rwflag
| crflag
, mode
);
1311 flags
->action
= ACTION_WRITE
;
1312 return fd
; /* success */
1314 return fd
; /* failure */
1318 /* open_external()-- Open an external file, unix specific version.
1319 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1320 * Returns NULL on operating system error. */
1323 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1327 if (flags
->status
== STATUS_SCRATCH
)
1329 fd
= tempfile (opp
);
1330 if (flags
->action
== ACTION_UNSPECIFIED
)
1331 flags
->action
= ACTION_READWRITE
;
1333 #if HAVE_UNLINK_OPEN_FILE
1334 /* We can unlink scratch files now and it will go away when closed. */
1341 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1343 fd
= regular_file (opp
, flags
);
1350 return fd_to_stream (fd
);
1354 /* input_stream()-- Return a stream pointer to the default input stream.
1355 * Called on initialization. */
1360 return fd_to_stream (STDIN_FILENO
);
1364 /* output_stream()-- Return a stream pointer to the default output stream.
1365 * Called on initialization. */
1368 output_stream (void)
1372 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1373 setmode (STDOUT_FILENO
, O_BINARY
);
1376 s
= fd_to_stream (STDOUT_FILENO
);
1381 /* error_stream()-- Return a stream pointer to the default error stream.
1382 * Called on initialization. */
1389 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1390 setmode (STDERR_FILENO
, O_BINARY
);
1393 s
= fd_to_stream (STDERR_FILENO
);
1398 /* compare_file_filename()-- Given an open stream and a fortran string
1399 * that is a filename, figure out if the file is the same as the
1403 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1405 char path
[min(PATH_MAX
, len
+ 1)];
1407 #ifdef HAVE_WORKING_STAT
1415 if (unpack_filename (path
, name
, len
))
1416 return 0; /* Can't be the same */
1418 /* If the filename doesn't exist, then there is no match with the
1421 if (stat (path
, &st
) < 0)
1424 #ifdef HAVE_WORKING_STAT
1425 s
= (unix_stream
*) (u
->s
);
1426 return (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1430 /* We try to match files by a unique ID. On some filesystems (network
1431 fs and FAT), we can't generate this unique ID, and will simply compare
1433 id1
= id_from_path (path
);
1434 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1436 return (id1
== id2
);
1439 if (len
!= u
->file_len
)
1441 return (memcmp(path
, u
->file
, len
) == 0);
1446 #ifdef HAVE_WORKING_STAT
1447 # define FIND_FILE0_DECL struct stat *st
1448 # define FIND_FILE0_ARGS st
1450 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1451 # define FIND_FILE0_ARGS id, file, file_len
1454 /* find_file0()-- Recursive work function for find_file() */
1457 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1460 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1467 #ifdef HAVE_WORKING_STAT
1470 unix_stream
*s
= (unix_stream
*) (u
->s
);
1471 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1476 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1483 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1487 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1491 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1499 /* find_file()-- Take the current filename and see if there is a unit
1500 * that has the file already open. Returns a pointer to the unit if so. */
1503 find_file (const char *file
, gfc_charlen_type file_len
)
1505 char path
[min(PATH_MAX
, file_len
+ 1)];
1508 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1512 if (unpack_filename (path
, file
, file_len
))
1515 if (stat (path
, &st
[0]) < 0)
1518 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1519 id
= id_from_path (path
);
1522 __gthread_mutex_lock (&unit_lock
);
1524 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1528 if (! __gthread_mutex_trylock (&u
->lock
))
1530 /* assert (u->closed == 0); */
1531 __gthread_mutex_unlock (&unit_lock
);
1535 inc_waiting_locked (u
);
1537 __gthread_mutex_unlock (&unit_lock
);
1540 __gthread_mutex_lock (&u
->lock
);
1543 __gthread_mutex_lock (&unit_lock
);
1544 __gthread_mutex_unlock (&u
->lock
);
1545 if (predec_waiting_locked (u
) == 0)
1550 dec_waiting_unlocked (u
);
1556 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1560 if (u
->unit_number
> min_unit
)
1562 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1566 if (u
->unit_number
>= min_unit
)
1568 if (__gthread_mutex_trylock (&u
->lock
))
1572 __gthread_mutex_unlock (&u
->lock
);
1580 flush_all_units (void)
1585 __gthread_mutex_lock (&unit_lock
);
1588 u
= flush_all_units_1 (unit_root
, min_unit
);
1590 inc_waiting_locked (u
);
1591 __gthread_mutex_unlock (&unit_lock
);
1595 __gthread_mutex_lock (&u
->lock
);
1597 min_unit
= u
->unit_number
+ 1;
1602 __gthread_mutex_lock (&unit_lock
);
1603 __gthread_mutex_unlock (&u
->lock
);
1604 (void) predec_waiting_locked (u
);
1608 __gthread_mutex_lock (&unit_lock
);
1609 __gthread_mutex_unlock (&u
->lock
);
1610 if (predec_waiting_locked (u
) == 0)
1618 /* delete_file()-- Given a unit structure, delete the file associated
1619 * with the unit. Returns nonzero if something went wrong. */
1622 delete_file (gfc_unit
* u
)
1624 char path
[min(PATH_MAX
, u
->file_len
+ 1)];
1625 int err
= unpack_filename (path
, u
->file
, u
->file_len
);
1628 { /* Shouldn't be possible */
1633 return unlink (path
);
1637 /* file_exists()-- Returns nonzero if the current filename exists on
1641 file_exists (const char *file
, gfc_charlen_type file_len
)
1643 char path
[min(PATH_MAX
, file_len
+ 1)];
1645 if (unpack_filename (path
, file
, file_len
))
1648 return !(access (path
, F_OK
));
1652 /* file_size()-- Returns the size of the file. */
1655 file_size (const char *file
, gfc_charlen_type file_len
)
1657 char path
[min(PATH_MAX
, file_len
+ 1)];
1658 struct stat statbuf
;
1660 if (unpack_filename (path
, file
, file_len
))
1663 if (stat (path
, &statbuf
) < 0)
1666 return (GFC_IO_INT
) statbuf
.st_size
;
1669 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1671 /* inquire_sequential()-- Given a fortran string, determine if the
1672 * file is suitable for sequential access. Returns a C-style
1676 inquire_sequential (const char *string
, int len
)
1678 char path
[min(PATH_MAX
, len
+ 1)];
1679 struct stat statbuf
;
1681 if (string
== NULL
||
1682 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1685 if (S_ISREG (statbuf
.st_mode
) ||
1686 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1689 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1696 /* inquire_direct()-- Given a fortran string, determine if the file is
1697 * suitable for direct access. Returns a C-style string. */
1700 inquire_direct (const char *string
, int len
)
1702 char path
[min(PATH_MAX
, len
+ 1)];
1703 struct stat statbuf
;
1705 if (string
== NULL
||
1706 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1709 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1712 if (S_ISDIR (statbuf
.st_mode
) ||
1713 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1720 /* inquire_formatted()-- Given a fortran string, determine if the file
1721 * is suitable for formatted form. Returns a C-style string. */
1724 inquire_formatted (const char *string
, int len
)
1726 char path
[min(PATH_MAX
, len
+ 1)];
1727 struct stat statbuf
;
1729 if (string
== NULL
||
1730 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1733 if (S_ISREG (statbuf
.st_mode
) ||
1734 S_ISBLK (statbuf
.st_mode
) ||
1735 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1738 if (S_ISDIR (statbuf
.st_mode
))
1745 /* inquire_unformatted()-- Given a fortran string, determine if the file
1746 * is suitable for unformatted form. Returns a C-style string. */
1749 inquire_unformatted (const char *string
, int len
)
1751 return inquire_formatted (string
, len
);
1755 /* inquire_access()-- Given a fortran string, determine if the file is
1756 * suitable for access. */
1759 inquire_access (const char *string
, int len
, int mode
)
1761 char path
[min(PATH_MAX
, len
+ 1)];
1763 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1764 access (path
, mode
) < 0)
1771 /* inquire_read()-- Given a fortran string, determine if the file is
1772 * suitable for READ access. */
1775 inquire_read (const char *string
, int len
)
1777 return inquire_access (string
, len
, R_OK
);
1781 /* inquire_write()-- Given a fortran string, determine if the file is
1782 * suitable for READ access. */
1785 inquire_write (const char *string
, int len
)
1787 return inquire_access (string
, len
, W_OK
);
1791 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1792 * suitable for read and write access. */
1795 inquire_readwrite (const char *string
, int len
)
1797 return inquire_access (string
, len
, R_OK
| W_OK
);
1802 stream_isatty (stream
*s
)
1804 return isatty (((unix_stream
*) s
)->fd
);
1808 stream_ttyname (stream
*s
__attribute__ ((unused
)),
1809 char * buf
__attribute__ ((unused
)),
1810 size_t buflen
__attribute__ ((unused
)))
1812 #ifdef HAVE_TTYNAME_R
1813 return ttyname_r (((unix_stream
*) s
)->fd
, buf
, buflen
);
1814 #elif defined HAVE_TTYNAME
1817 p
= ttyname (((unix_stream
*) s
)->fd
);
1823 memcpy (buf
, p
, plen
);
1833 /* How files are stored: This is an operating-system specific issue,
1834 and therefore belongs here. There are three cases to consider.
1837 Records are written as block of bytes corresponding to the record
1838 length of the file. This goes for both formatted and unformatted
1839 records. Positioning is done explicitly for each data transfer,
1840 so positioning is not much of an issue.
1842 Sequential Formatted:
1843 Records are separated by newline characters. The newline character
1844 is prohibited from appearing in a string. If it does, this will be
1845 messed up on the next read. End of file is also the end of a record.
1847 Sequential Unformatted:
1848 In this case, we are merely copying bytes to and from main storage,
1849 yet we need to keep track of varying record lengths. We adopt
1850 the solution used by f2c. Each record contains a pair of length
1853 Length of record n in bytes
1855 Length of record n in bytes
1857 Length of record n+1 in bytes
1859 Length of record n+1 in bytes
1861 The length is stored at the end of a record to allow backspacing to the
1862 previous record. Between data transfer statements, the file pointer
1863 is left pointing to the first length of the current record.
1865 ENDFILE records are never explicitly stored.