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, -1 if not seekable. */
192 char *buffer
; /* Pointer to the buffer. */
193 int fd
; /* The POSIX file descriptor. */
195 int active
; /* Length of valid bytes in the buffer */
197 int ndirty
; /* Dirty bytes starting at buffer_offset */
199 int special_file
; /* =1 if the fd refers to a special file */
201 /* Cached stat(2) values. */
208 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
209 * standard descriptors, returning a non-standard descriptor. If the
210 * user specifies that system errors should go to standard output,
211 * then closes standard output, we don't want the system errors to a
212 * file that has been given file descriptor 1 or 0. We want to send
213 * the error to the invalid descriptor. */
219 int input
, output
, error
;
221 input
= output
= error
= 0;
223 /* Unix allocates the lowest descriptors first, so a loop is not
224 required, but this order is. */
225 if (fd
== STDIN_FILENO
)
230 if (fd
== STDOUT_FILENO
)
235 if (fd
== STDERR_FILENO
)
242 close (STDIN_FILENO
);
244 close (STDOUT_FILENO
);
246 close (STDERR_FILENO
);
253 /* If the stream corresponds to a preconnected unit, we flush the
254 corresponding C stream. This is bugware for mixed C-Fortran codes
255 where the C code doesn't flush I/O before returning. */
257 flush_if_preconnected (stream
* s
)
261 fd
= ((unix_stream
*) s
)->fd
;
262 if (fd
== STDIN_FILENO
)
264 else if (fd
== STDOUT_FILENO
)
266 else if (fd
== STDERR_FILENO
)
271 /********************************************************************
272 Raw I/O functions (read, write, seek, tell, truncate, close).
274 These functions wrap the basic POSIX I/O syscalls. Any deviation in
275 semantics is a bug, except the following: write restarts in case
276 of being interrupted by a signal, and as the first argument the
277 functions take the unix_stream struct rather than an integer file
278 descriptor. Also, for POSIX read() and write() a nbyte argument larger
279 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
280 than size_t as for POSIX read/write.
281 *********************************************************************/
284 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
290 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
292 /* For read we can't do I/O in a loop like raw_write does, because
293 that will break applications that wait for interactive I/O. */
294 return read (s
->fd
, buf
, nbyte
);
298 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
300 ssize_t trans
, bytes_left
;
304 buf_st
= (char *) buf
;
306 /* We must write in a loop since some systems don't restart system
307 calls in case of a signal. */
308 while (bytes_left
> 0)
310 trans
= write (s
->fd
, buf_st
, bytes_left
);
322 return nbyte
- bytes_left
;
326 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
328 return lseek (s
->fd
, offset
, whence
);
332 raw_tell (unix_stream
* s
)
334 return lseek (s
->fd
, 0, SEEK_CUR
);
338 raw_truncate (unix_stream
* s
, gfc_offset length
)
349 h
= (HANDLE
) _get_osfhandle (s
->fd
);
350 if (h
== INVALID_HANDLE_VALUE
)
355 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
358 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
360 if (!SetEndOfFile (h
))
365 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
369 lseek (s
->fd
, cur
, SEEK_SET
);
371 #elif defined HAVE_FTRUNCATE
372 return ftruncate (s
->fd
, length
);
373 #elif defined HAVE_CHSIZE
374 return chsize (s
->fd
, length
);
376 runtime_error ("required ftruncate or chsize support not present");
382 raw_close (unix_stream
* s
)
386 if (s
->fd
!= STDOUT_FILENO
387 && s
->fd
!= STDERR_FILENO
388 && s
->fd
!= STDIN_FILENO
)
389 retval
= close (s
->fd
);
397 raw_init (unix_stream
* s
)
399 s
->st
.read
= (void *) raw_read
;
400 s
->st
.write
= (void *) raw_write
;
401 s
->st
.seek
= (void *) raw_seek
;
402 s
->st
.tell
= (void *) raw_tell
;
403 s
->st
.trunc
= (void *) raw_truncate
;
404 s
->st
.close
= (void *) raw_close
;
405 s
->st
.flush
= (void *) raw_flush
;
412 /*********************************************************************
413 Buffered I/O functions. These functions have the same semantics as the
414 raw I/O functions above, except that they are buffered in order to
415 improve performance. The buffer must be flushed when switching from
416 reading to writing and vice versa.
417 *********************************************************************/
420 buf_flush (unix_stream
* s
)
424 /* Flushing in read mode means discarding read bytes. */
430 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
431 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
434 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
436 s
->physical_offset
= s
->buffer_offset
+ writelen
;
438 /* Don't increment file_length if the file is non-seekable. */
439 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
440 s
->file_length
= s
->physical_offset
;
442 s
->ndirty
-= writelen
;
454 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
457 s
->buffer_offset
= s
->logical_offset
;
459 /* Is the data we want in the buffer? */
460 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
461 && s
->buffer_offset
<= s
->logical_offset
)
462 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
465 /* First copy the active bytes if applicable, then read the rest
466 either directly or filling the buffer. */
469 ssize_t to_read
, did_read
;
470 gfc_offset new_logical
;
473 if (s
->logical_offset
>= s
->buffer_offset
474 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
476 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
477 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
481 /* At this point we consider all bytes in the buffer discarded. */
482 to_read
= nbyte
- nread
;
483 new_logical
= s
->logical_offset
+ nread
;
484 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
485 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
487 s
->buffer_offset
= s
->physical_offset
= new_logical
;
488 if (to_read
<= BUFFER_SIZE
/2)
490 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
491 s
->physical_offset
+= did_read
;
492 s
->active
= did_read
;
493 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
494 memcpy (p
, s
->buffer
, did_read
);
498 did_read
= raw_read (s
, p
, to_read
);
499 s
->physical_offset
+= did_read
;
502 nbyte
= did_read
+ nread
;
504 s
->logical_offset
+= nbyte
;
509 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
512 s
->buffer_offset
= s
->logical_offset
;
514 /* Does the data fit into the buffer? As a special case, if the
515 buffer is empty and the request is bigger than BUFFER_SIZE/2,
516 write directly. This avoids the case where the buffer would have
517 to be flushed at every write. */
518 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
519 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
520 && s
->buffer_offset
<= s
->logical_offset
521 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
523 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
524 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
530 /* Flush, and either fill the buffer with the new data, or if
531 the request is bigger than the buffer size, write directly
532 bypassing the buffer. */
534 if (nbyte
<= BUFFER_SIZE
/2)
536 memcpy (s
->buffer
, buf
, nbyte
);
537 s
->buffer_offset
= s
->logical_offset
;
542 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
)
544 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
546 s
->physical_offset
= s
->logical_offset
;
549 nbyte
= raw_write (s
, buf
, nbyte
);
550 s
->physical_offset
+= nbyte
;
553 s
->logical_offset
+= nbyte
;
554 /* Don't increment file_length if the file is non-seekable. */
555 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
556 s
->file_length
= s
->logical_offset
;
561 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
568 offset
+= s
->logical_offset
;
571 offset
+= s
->file_length
;
581 s
->logical_offset
= offset
;
586 buf_tell (unix_stream
* s
)
588 return s
->logical_offset
;
592 buf_truncate (unix_stream
* s
, gfc_offset length
)
596 if (buf_flush (s
) != 0)
598 r
= raw_truncate (s
, length
);
600 s
->file_length
= length
;
605 buf_close (unix_stream
* s
)
607 if (buf_flush (s
) != 0)
610 return raw_close (s
);
614 buf_init (unix_stream
* s
)
616 s
->st
.read
= (void *) buf_read
;
617 s
->st
.write
= (void *) buf_write
;
618 s
->st
.seek
= (void *) buf_seek
;
619 s
->st
.tell
= (void *) buf_tell
;
620 s
->st
.trunc
= (void *) buf_truncate
;
621 s
->st
.close
= (void *) buf_close
;
622 s
->st
.flush
= (void *) buf_flush
;
624 s
->buffer
= get_mem (BUFFER_SIZE
);
629 /*********************************************************************
630 memory stream functions - These are used for internal files
632 The idea here is that a single stream structure is created and all
633 requests must be satisfied from it. The location and size of the
634 buffer is the character variable supplied to the READ or WRITE
637 *********************************************************************/
640 mem_alloc_r (stream
* strm
, int * len
)
642 unix_stream
* s
= (unix_stream
*) strm
;
644 gfc_offset where
= s
->logical_offset
;
646 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
649 n
= s
->buffer_offset
+ s
->active
- where
;
653 s
->logical_offset
= where
+ *len
;
655 return s
->buffer
+ (where
- s
->buffer_offset
);
660 mem_alloc_r4 (stream
* strm
, int * len
)
662 unix_stream
* s
= (unix_stream
*) strm
;
664 gfc_offset where
= s
->logical_offset
;
666 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
669 n
= s
->buffer_offset
+ s
->active
- where
;
673 s
->logical_offset
= where
+ *len
;
675 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
680 mem_alloc_w (stream
* strm
, int * len
)
682 unix_stream
* s
= (unix_stream
*) strm
;
684 gfc_offset where
= s
->logical_offset
;
688 if (where
< s
->buffer_offset
)
691 if (m
> s
->file_length
)
694 s
->logical_offset
= m
;
696 return s
->buffer
+ (where
- s
->buffer_offset
);
701 mem_alloc_w4 (stream
* strm
, int * len
)
703 unix_stream
* s
= (unix_stream
*) strm
;
705 gfc_offset where
= s
->logical_offset
;
706 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
710 if (where
< s
->buffer_offset
)
713 if (m
> s
->file_length
)
716 s
->logical_offset
= m
;
717 return &result
[where
- s
->buffer_offset
];
721 /* Stream read function for character(kine=1) internal units. */
724 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
729 p
= mem_alloc_r (s
, &nb
);
740 /* Stream read function for chracter(kind=4) internal units. */
743 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
748 p
= mem_alloc_r (s
, &nb
);
759 /* Stream write function for character(kind=1) internal units. */
762 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
767 p
= mem_alloc_w (s
, &nb
);
778 /* Stream write function for character(kind=4) internal units. */
781 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
786 p
= mem_alloc_w4 (s
, &nw
);
790 *p
++ = (gfc_char4_t
) *((char *) buf
);
799 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
801 unix_stream
* s
= (unix_stream
*) strm
;
807 offset
+= s
->logical_offset
;
810 offset
+= s
->file_length
;
816 /* Note that for internal array I/O it's actually possible to have a
817 negative offset, so don't check for that. */
818 if (offset
> s
->file_length
)
824 s
->logical_offset
= offset
;
826 /* Returning < 0 is the error indicator for sseek(), so return 0 if
827 offset is negative. Thus if the return value is 0, the caller
828 has to use stell() to get the real value of logical_offset. */
836 mem_tell (stream
* s
)
838 return ((unix_stream
*)s
)->logical_offset
;
843 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
844 gfc_offset length
__attribute__ ((unused
)))
851 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
858 mem_close (unix_stream
* s
)
866 /*********************************************************************
867 Public functions -- A reimplementation of this module needs to
868 define functional equivalents of the following.
869 *********************************************************************/
871 /* open_internal()-- Returns a stream structure from a character(kind=1)
875 open_internal (char *base
, int length
, gfc_offset offset
)
879 s
= get_mem (sizeof (unix_stream
));
880 memset (s
, '\0', sizeof (unix_stream
));
883 s
->buffer_offset
= offset
;
885 s
->logical_offset
= 0;
886 s
->active
= s
->file_length
= length
;
888 s
->st
.close
= (void *) mem_close
;
889 s
->st
.seek
= (void *) mem_seek
;
890 s
->st
.tell
= (void *) mem_tell
;
891 s
->st
.trunc
= (void *) mem_truncate
;
892 s
->st
.read
= (void *) mem_read
;
893 s
->st
.write
= (void *) mem_write
;
894 s
->st
.flush
= (void *) mem_flush
;
899 /* open_internal4()-- Returns a stream structure from a character(kind=4)
903 open_internal4 (char *base
, int length
, gfc_offset offset
)
907 s
= get_mem (sizeof (unix_stream
));
908 memset (s
, '\0', sizeof (unix_stream
));
911 s
->buffer_offset
= offset
;
913 s
->logical_offset
= 0;
914 s
->active
= s
->file_length
= length
;
916 s
->st
.close
= (void *) mem_close
;
917 s
->st
.seek
= (void *) mem_seek
;
918 s
->st
.tell
= (void *) mem_tell
;
919 s
->st
.trunc
= (void *) mem_truncate
;
920 s
->st
.read
= (void *) mem_read4
;
921 s
->st
.write
= (void *) mem_write4
;
922 s
->st
.flush
= (void *) mem_flush
;
928 /* fd_to_stream()-- Given an open file descriptor, build a stream
932 fd_to_stream (int fd
)
937 s
= get_mem (sizeof (unix_stream
));
938 memset (s
, '\0', sizeof (unix_stream
));
941 s
->buffer_offset
= 0;
942 s
->physical_offset
= 0;
943 s
->logical_offset
= 0;
945 /* Get the current length of the file. */
947 fstat (fd
, &statbuf
);
949 s
->st_dev
= statbuf
.st_dev
;
950 s
->st_ino
= statbuf
.st_ino
;
951 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
953 if (S_ISREG (statbuf
.st_mode
))
954 s
->file_length
= statbuf
.st_size
;
955 else if (S_ISBLK (statbuf
.st_mode
))
957 /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)? */
958 gfc_offset cur
= lseek (fd
, 0, SEEK_CUR
);
959 s
->file_length
= lseek (fd
, 0, SEEK_END
);
960 lseek (fd
, cur
, SEEK_SET
);
965 if (!(S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
966 || options
.all_unbuffered
967 ||(options
.unbuffered_preconnected
&&
968 (s
->fd
== STDIN_FILENO
969 || s
->fd
== STDOUT_FILENO
970 || s
->fd
== STDERR_FILENO
))
980 /* Given the Fortran unit number, convert it to a C file descriptor. */
983 unit_to_fd (int unit
)
988 us
= find_unit (unit
);
992 fd
= ((unix_stream
*) us
->s
)->fd
;
998 /* unpack_filename()-- Given a fortran string and a pointer to a
999 * buffer that is PATH_MAX characters, convert the fortran string to a
1000 * C string in the buffer. Returns nonzero if this is not possible. */
1003 unpack_filename (char *cstring
, const char *fstring
, int len
)
1005 if (fstring
== NULL
)
1007 len
= fstrlen (fstring
, len
);
1008 if (len
>= PATH_MAX
)
1009 return ENAMETOOLONG
;
1011 memmove (cstring
, fstring
, len
);
1012 cstring
[len
] = '\0';
1018 /* tempfile()-- Generate a temporary filename for a scratch file and
1019 * open it. mkstemp() opens the file for reading and writing, but the
1020 * library mode prevents anything that is not allowed. The descriptor
1021 * is returned, which is -1 on error. The template is pointed to by
1022 * opp->file, which is copied into the unit structure
1023 * and freed later. */
1026 tempfile (st_parameter_open
*opp
)
1028 const char *tempdir
;
1030 const char *slash
= "/";
1034 #ifndef HAVE_MKSTEMP
1039 tempdir
= getenv ("GFORTRAN_TMPDIR");
1041 if (tempdir
== NULL
)
1043 char buffer
[MAX_PATH
+ 1];
1045 ret
= GetTempPath (MAX_PATH
, buffer
);
1046 /* If we are not able to get a temp-directory, we use
1047 current directory. */
1048 if (ret
> MAX_PATH
|| !ret
)
1052 tempdir
= strdup (buffer
);
1055 if (tempdir
== NULL
)
1056 tempdir
= getenv ("TMP");
1057 if (tempdir
== NULL
)
1058 tempdir
= getenv ("TEMP");
1059 if (tempdir
== NULL
)
1060 tempdir
= DEFAULT_TEMPDIR
;
1063 /* Check for special case that tempdir contains slash
1064 or backslash at end. */
1065 tempdirlen
= strlen (tempdir
);
1066 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1068 || tempdir
[tempdirlen
- 1] == '\\'
1073 // Take care that the template is longer in the mktemp() branch.
1074 template = get_mem (tempdirlen
+ 23);
1077 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpXXXXXX",
1080 fd
= mkstemp (template);
1082 #else /* HAVE_MKSTEMP */
1085 slashlen
= strlen (slash
);
1088 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpaaaXXXXXX",
1093 template[tempdirlen
+ slashlen
+ 13] = 'a' + (c
% 26);
1095 template[tempdirlen
+ slashlen
+ 12] = 'a' + (c
% 26);
1097 template[tempdirlen
+ slashlen
+ 11] = 'a' + (c
% 26);
1102 if (!mktemp (template))
1109 #if defined(HAVE_CRLF) && defined(O_BINARY)
1110 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1111 S_IREAD
| S_IWRITE
);
1113 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1116 while (fd
== -1 && errno
== EEXIST
);
1117 #endif /* HAVE_MKSTEMP */
1119 opp
->file
= template;
1120 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1126 /* regular_file()-- Open a regular file.
1127 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1128 * unless an error occurs.
1129 * Returns the descriptor, which is less than zero on error. */
1132 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1134 char path
[min(PATH_MAX
, opp
->file_len
+ 1)];
1141 err
= unpack_filename (path
, opp
->file
, opp
->file_len
);
1144 errno
= err
; /* Fake an OS error */
1149 if (opp
->file_len
== 7)
1151 if (strncmp (path
, "CONOUT$", 7) == 0
1152 || strncmp (path
, "CONERR$", 7) == 0)
1154 fd
= open ("/dev/conout", O_WRONLY
);
1155 flags
->action
= ACTION_WRITE
;
1160 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1162 fd
= open ("/dev/conin", O_RDONLY
);
1163 flags
->action
= ACTION_READ
;
1170 if (opp
->file_len
== 7)
1172 if (strncmp (path
, "CONOUT$", 7) == 0
1173 || strncmp (path
, "CONERR$", 7) == 0)
1175 fd
= open ("CONOUT$", O_WRONLY
);
1176 flags
->action
= ACTION_WRITE
;
1181 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1183 fd
= open ("CONIN$", O_RDONLY
);
1184 flags
->action
= ACTION_READ
;
1191 switch (flags
->action
)
1201 case ACTION_READWRITE
:
1202 case ACTION_UNSPECIFIED
:
1207 internal_error (&opp
->common
, "regular_file(): Bad action");
1210 switch (flags
->status
)
1213 crflag
= O_CREAT
| O_EXCL
;
1216 case STATUS_OLD
: /* open will fail if the file does not exist*/
1220 case STATUS_UNKNOWN
:
1221 case STATUS_SCRATCH
:
1225 case STATUS_REPLACE
:
1226 crflag
= O_CREAT
| O_TRUNC
;
1230 internal_error (&opp
->common
, "regular_file(): Bad status");
1233 /* rwflag |= O_LARGEFILE; */
1235 #if defined(HAVE_CRLF) && defined(O_BINARY)
1239 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1240 fd
= open (path
, rwflag
| crflag
, mode
);
1241 if (flags
->action
!= ACTION_UNSPECIFIED
)
1246 flags
->action
= ACTION_READWRITE
;
1249 if (errno
!= EACCES
&& errno
!= EROFS
)
1252 /* retry for read-only access */
1254 fd
= open (path
, rwflag
| crflag
, mode
);
1257 flags
->action
= ACTION_READ
;
1258 return fd
; /* success */
1261 if (errno
!= EACCES
)
1262 return fd
; /* failure */
1264 /* retry for write-only access */
1266 fd
= open (path
, rwflag
| crflag
, mode
);
1269 flags
->action
= ACTION_WRITE
;
1270 return fd
; /* success */
1272 return fd
; /* failure */
1276 /* open_external()-- Open an external file, unix specific version.
1277 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1278 * Returns NULL on operating system error. */
1281 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1285 if (flags
->status
== STATUS_SCRATCH
)
1287 fd
= tempfile (opp
);
1288 if (flags
->action
== ACTION_UNSPECIFIED
)
1289 flags
->action
= ACTION_READWRITE
;
1291 #if HAVE_UNLINK_OPEN_FILE
1292 /* We can unlink scratch files now and it will go away when closed. */
1299 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1301 fd
= regular_file (opp
, flags
);
1308 return fd_to_stream (fd
);
1312 /* input_stream()-- Return a stream pointer to the default input stream.
1313 * Called on initialization. */
1318 return fd_to_stream (STDIN_FILENO
);
1322 /* output_stream()-- Return a stream pointer to the default output stream.
1323 * Called on initialization. */
1326 output_stream (void)
1330 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1331 setmode (STDOUT_FILENO
, O_BINARY
);
1334 s
= fd_to_stream (STDOUT_FILENO
);
1339 /* error_stream()-- Return a stream pointer to the default error stream.
1340 * Called on initialization. */
1347 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1348 setmode (STDERR_FILENO
, O_BINARY
);
1351 s
= fd_to_stream (STDERR_FILENO
);
1356 /* compare_file_filename()-- Given an open stream and a fortran string
1357 * that is a filename, figure out if the file is the same as the
1361 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1363 char path
[min(PATH_MAX
, len
+ 1)];
1365 #ifdef HAVE_WORKING_STAT
1373 if (unpack_filename (path
, name
, len
))
1374 return 0; /* Can't be the same */
1376 /* If the filename doesn't exist, then there is no match with the
1379 if (stat (path
, &st
) < 0)
1382 #ifdef HAVE_WORKING_STAT
1383 s
= (unix_stream
*) (u
->s
);
1384 return (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1388 /* We try to match files by a unique ID. On some filesystems (network
1389 fs and FAT), we can't generate this unique ID, and will simply compare
1391 id1
= id_from_path (path
);
1392 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1394 return (id1
== id2
);
1397 if (len
!= u
->file_len
)
1399 return (memcmp(path
, u
->file
, len
) == 0);
1404 #ifdef HAVE_WORKING_STAT
1405 # define FIND_FILE0_DECL struct stat *st
1406 # define FIND_FILE0_ARGS st
1408 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1409 # define FIND_FILE0_ARGS id, file, file_len
1412 /* find_file0()-- Recursive work function for find_file() */
1415 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1418 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1425 #ifdef HAVE_WORKING_STAT
1428 unix_stream
*s
= (unix_stream
*) (u
->s
);
1429 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1434 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1441 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1445 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1449 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1457 /* find_file()-- Take the current filename and see if there is a unit
1458 * that has the file already open. Returns a pointer to the unit if so. */
1461 find_file (const char *file
, gfc_charlen_type file_len
)
1463 char path
[min(PATH_MAX
, file_len
+ 1)];
1466 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1470 if (unpack_filename (path
, file
, file_len
))
1473 if (stat (path
, &st
[0]) < 0)
1476 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1477 id
= id_from_path (path
);
1480 __gthread_mutex_lock (&unit_lock
);
1482 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1486 if (! __gthread_mutex_trylock (&u
->lock
))
1488 /* assert (u->closed == 0); */
1489 __gthread_mutex_unlock (&unit_lock
);
1493 inc_waiting_locked (u
);
1495 __gthread_mutex_unlock (&unit_lock
);
1498 __gthread_mutex_lock (&u
->lock
);
1501 __gthread_mutex_lock (&unit_lock
);
1502 __gthread_mutex_unlock (&u
->lock
);
1503 if (predec_waiting_locked (u
) == 0)
1508 dec_waiting_unlocked (u
);
1514 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1518 if (u
->unit_number
> min_unit
)
1520 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1524 if (u
->unit_number
>= min_unit
)
1526 if (__gthread_mutex_trylock (&u
->lock
))
1530 __gthread_mutex_unlock (&u
->lock
);
1538 flush_all_units (void)
1543 __gthread_mutex_lock (&unit_lock
);
1546 u
= flush_all_units_1 (unit_root
, min_unit
);
1548 inc_waiting_locked (u
);
1549 __gthread_mutex_unlock (&unit_lock
);
1553 __gthread_mutex_lock (&u
->lock
);
1555 min_unit
= u
->unit_number
+ 1;
1560 __gthread_mutex_lock (&unit_lock
);
1561 __gthread_mutex_unlock (&u
->lock
);
1562 (void) predec_waiting_locked (u
);
1566 __gthread_mutex_lock (&unit_lock
);
1567 __gthread_mutex_unlock (&u
->lock
);
1568 if (predec_waiting_locked (u
) == 0)
1576 /* delete_file()-- Given a unit structure, delete the file associated
1577 * with the unit. Returns nonzero if something went wrong. */
1580 delete_file (gfc_unit
* u
)
1582 char path
[min(PATH_MAX
, u
->file_len
+ 1)];
1583 int err
= unpack_filename (path
, u
->file
, u
->file_len
);
1586 { /* Shouldn't be possible */
1591 return unlink (path
);
1595 /* file_exists()-- Returns nonzero if the current filename exists on
1599 file_exists (const char *file
, gfc_charlen_type file_len
)
1601 char path
[min(PATH_MAX
, file_len
+ 1)];
1603 if (unpack_filename (path
, file
, file_len
))
1606 return !(access (path
, F_OK
));
1610 /* file_size()-- Returns the size of the file. */
1613 file_size (const char *file
, gfc_charlen_type file_len
)
1615 char path
[min(PATH_MAX
, file_len
+ 1)];
1616 struct stat statbuf
;
1618 if (unpack_filename (path
, file
, file_len
))
1621 if (stat (path
, &statbuf
) < 0)
1624 return (GFC_IO_INT
) statbuf
.st_size
;
1627 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1629 /* inquire_sequential()-- Given a fortran string, determine if the
1630 * file is suitable for sequential access. Returns a C-style
1634 inquire_sequential (const char *string
, int len
)
1636 char path
[min(PATH_MAX
, len
+ 1)];
1637 struct stat statbuf
;
1639 if (string
== NULL
||
1640 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1643 if (S_ISREG (statbuf
.st_mode
) ||
1644 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1647 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1654 /* inquire_direct()-- Given a fortran string, determine if the file is
1655 * suitable for direct access. Returns a C-style string. */
1658 inquire_direct (const char *string
, int len
)
1660 char path
[min(PATH_MAX
, len
+ 1)];
1661 struct stat statbuf
;
1663 if (string
== NULL
||
1664 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1667 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1670 if (S_ISDIR (statbuf
.st_mode
) ||
1671 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1678 /* inquire_formatted()-- Given a fortran string, determine if the file
1679 * is suitable for formatted form. Returns a C-style string. */
1682 inquire_formatted (const char *string
, int len
)
1684 char path
[min(PATH_MAX
, len
+ 1)];
1685 struct stat statbuf
;
1687 if (string
== NULL
||
1688 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1691 if (S_ISREG (statbuf
.st_mode
) ||
1692 S_ISBLK (statbuf
.st_mode
) ||
1693 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1696 if (S_ISDIR (statbuf
.st_mode
))
1703 /* inquire_unformatted()-- Given a fortran string, determine if the file
1704 * is suitable for unformatted form. Returns a C-style string. */
1707 inquire_unformatted (const char *string
, int len
)
1709 return inquire_formatted (string
, len
);
1713 /* inquire_access()-- Given a fortran string, determine if the file is
1714 * suitable for access. */
1717 inquire_access (const char *string
, int len
, int mode
)
1719 char path
[min(PATH_MAX
, len
+ 1)];
1721 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1722 access (path
, mode
) < 0)
1729 /* inquire_read()-- Given a fortran string, determine if the file is
1730 * suitable for READ access. */
1733 inquire_read (const char *string
, int len
)
1735 return inquire_access (string
, len
, R_OK
);
1739 /* inquire_write()-- Given a fortran string, determine if the file is
1740 * suitable for READ access. */
1743 inquire_write (const char *string
, int len
)
1745 return inquire_access (string
, len
, W_OK
);
1749 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1750 * suitable for read and write access. */
1753 inquire_readwrite (const char *string
, int len
)
1755 return inquire_access (string
, len
, R_OK
| W_OK
);
1759 /* file_length()-- Return the file length in bytes, -1 if unknown */
1762 file_length (stream
* s
)
1764 gfc_offset curr
, end
;
1765 if (!is_seekable (s
))
1770 end
= sseek (s
, 0, SEEK_END
);
1771 sseek (s
, curr
, SEEK_SET
);
1776 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1780 is_seekable (stream
*s
)
1782 /* By convention, if file_length == -1, the file is not
1784 return ((unix_stream
*) s
)->file_length
!=-1;
1788 /* is_special()-- Return nonzero if the stream is not a regular file. */
1791 is_special (stream
*s
)
1793 return ((unix_stream
*) s
)->special_file
;
1798 stream_isatty (stream
*s
)
1800 return isatty (((unix_stream
*) s
)->fd
);
1804 stream_ttyname (stream
*s
__attribute__ ((unused
)),
1805 char * buf
__attribute__ ((unused
)),
1806 size_t buflen
__attribute__ ((unused
)))
1808 #ifdef HAVE_TTYNAME_R
1809 return ttyname_r (((unix_stream
*) s
)->fd
, buf
, buflen
);
1810 #elif defined HAVE_TTYNAME
1813 p
= ttyname (((unix_stream
*) s
)->fd
);
1819 memcpy (buf
, p
, plen
);
1829 /* How files are stored: This is an operating-system specific issue,
1830 and therefore belongs here. There are three cases to consider.
1833 Records are written as block of bytes corresponding to the record
1834 length of the file. This goes for both formatted and unformatted
1835 records. Positioning is done explicitly for each data transfer,
1836 so positioning is not much of an issue.
1838 Sequential Formatted:
1839 Records are separated by newline characters. The newline character
1840 is prohibited from appearing in a string. If it does, this will be
1841 messed up on the next read. End of file is also the end of a record.
1843 Sequential Unformatted:
1844 In this case, we are merely copying bytes to and from main storage,
1845 yet we need to keep track of varying record lengths. We adopt
1846 the solution used by f2c. Each record contains a pair of length
1849 Length of record n in bytes
1851 Length of record n in bytes
1853 Length of record n+1 in bytes
1855 Length of record n+1 in bytes
1857 The length is stored at the end of a record to allow backspacing to the
1858 previous record. Between data transfer statements, the file pointer
1859 is left pointing to the first length of the current record.
1861 ENDFILE records are never explicitly stored.