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 /* For mingw, we don't identify files by their inode number, but by a
45 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
48 #define WIN32_LEAN_AND_MEAN
51 #define lseek _lseeki64
52 #define fstat _fstati64
54 typedef struct _stati64 gfstat_t
;
56 #ifndef HAVE_WORKING_STAT
58 id_from_handle (HANDLE hFile
)
60 BY_HANDLE_FILE_INFORMATION FileInformation
;
62 if (hFile
== INVALID_HANDLE_VALUE
)
65 memset (&FileInformation
, 0, sizeof(FileInformation
));
66 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
69 return ((uint64_t) FileInformation
.nFileIndexLow
)
70 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
75 id_from_path (const char *path
)
80 if (!path
|| !*path
|| access (path
, F_OK
))
83 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
84 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
86 res
= id_from_handle (hFile
);
93 id_from_fd (const int fd
)
95 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
101 typedef struct stat gfstat_t
;
105 #define PATH_MAX 1024
108 /* These flags aren't defined on all targets (mingw32), so provide them
141 /* Fallback implementation of access() on systems that don't have it.
142 Only modes R_OK, W_OK and F_OK are used in this file. */
145 fallback_access (const char *path
, int mode
)
147 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
150 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
156 return stat (path
, &st
);
163 #define access fallback_access
167 /* Unix and internal stream I/O module */
169 static const int BUFFER_SIZE
= 8192;
175 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
176 gfc_offset physical_offset
; /* Current physical file offset */
177 gfc_offset logical_offset
; /* Current logical file offset */
178 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
180 char *buffer
; /* Pointer to the buffer. */
181 int fd
; /* The POSIX file descriptor. */
183 int active
; /* Length of valid bytes in the buffer */
185 int ndirty
; /* Dirty bytes starting at buffer_offset */
187 int special_file
; /* =1 if the fd refers to a special file */
189 /* Cached stat(2) values. */
196 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
197 * standard descriptors, returning a non-standard descriptor. If the
198 * user specifies that system errors should go to standard output,
199 * then closes standard output, we don't want the system errors to a
200 * file that has been given file descriptor 1 or 0. We want to send
201 * the error to the invalid descriptor. */
207 int input
, output
, error
;
209 input
= output
= error
= 0;
211 /* Unix allocates the lowest descriptors first, so a loop is not
212 required, but this order is. */
213 if (fd
== STDIN_FILENO
)
218 if (fd
== STDOUT_FILENO
)
223 if (fd
== STDERR_FILENO
)
230 close (STDIN_FILENO
);
232 close (STDOUT_FILENO
);
234 close (STDERR_FILENO
);
241 /* If the stream corresponds to a preconnected unit, we flush the
242 corresponding C stream. This is bugware for mixed C-Fortran codes
243 where the C code doesn't flush I/O before returning. */
245 flush_if_preconnected (stream
* s
)
249 fd
= ((unix_stream
*) s
)->fd
;
250 if (fd
== STDIN_FILENO
)
252 else if (fd
== STDOUT_FILENO
)
254 else if (fd
== STDERR_FILENO
)
259 /* get_oserror()-- Get the most recent operating system error. For
260 * unix, this is errno. */
265 return strerror (errno
);
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_truncate (unix_stream
* s
, gfc_offset length
)
347 h
= (HANDLE
) _get_osfhandle (s
->fd
);
348 if (h
== INVALID_HANDLE_VALUE
)
353 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
356 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
358 if (!SetEndOfFile (h
))
363 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
367 lseek (s
->fd
, cur
, SEEK_SET
);
369 #elif defined HAVE_FTRUNCATE
370 return ftruncate (s
->fd
, length
);
371 #elif defined HAVE_CHSIZE
372 return chsize (s
->fd
, length
);
374 runtime_error ("required ftruncate or chsize support not present");
380 raw_close (unix_stream
* s
)
384 if (s
->fd
!= STDOUT_FILENO
385 && s
->fd
!= STDERR_FILENO
386 && s
->fd
!= STDIN_FILENO
)
387 retval
= close (s
->fd
);
395 raw_init (unix_stream
* s
)
397 s
->st
.read
= (void *) raw_read
;
398 s
->st
.write
= (void *) raw_write
;
399 s
->st
.seek
= (void *) raw_seek
;
400 s
->st
.tell
= (void *) raw_tell
;
401 s
->st
.trunc
= (void *) raw_truncate
;
402 s
->st
.close
= (void *) raw_close
;
403 s
->st
.flush
= (void *) raw_flush
;
410 /*********************************************************************
411 Buffered I/O functions. These functions have the same semantics as the
412 raw I/O functions above, except that they are buffered in order to
413 improve performance. The buffer must be flushed when switching from
414 reading to writing and vice versa.
415 *********************************************************************/
418 buf_flush (unix_stream
* s
)
422 /* Flushing in read mode means discarding read bytes. */
428 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
429 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
432 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
434 s
->physical_offset
= s
->buffer_offset
+ writelen
;
436 /* Don't increment file_length if the file is non-seekable. */
437 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
438 s
->file_length
= s
->physical_offset
;
440 s
->ndirty
-= writelen
;
452 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
455 s
->buffer_offset
= s
->logical_offset
;
457 /* Is the data we want in the buffer? */
458 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
459 && s
->buffer_offset
<= s
->logical_offset
)
460 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
463 /* First copy the active bytes if applicable, then read the rest
464 either directly or filling the buffer. */
467 ssize_t to_read
, did_read
;
468 gfc_offset new_logical
;
471 if (s
->logical_offset
>= s
->buffer_offset
472 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
474 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
475 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
479 /* At this point we consider all bytes in the buffer discarded. */
480 to_read
= nbyte
- nread
;
481 new_logical
= s
->logical_offset
+ nread
;
482 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
483 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
485 s
->buffer_offset
= s
->physical_offset
= new_logical
;
486 if (to_read
<= BUFFER_SIZE
/2)
488 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
489 s
->physical_offset
+= did_read
;
490 s
->active
= did_read
;
491 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
492 memcpy (p
, s
->buffer
, did_read
);
496 did_read
= raw_read (s
, p
, to_read
);
497 s
->physical_offset
+= did_read
;
500 nbyte
= did_read
+ nread
;
502 s
->logical_offset
+= nbyte
;
507 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
510 s
->buffer_offset
= s
->logical_offset
;
512 /* Does the data fit into the buffer? As a special case, if the
513 buffer is empty and the request is bigger than BUFFER_SIZE/2,
514 write directly. This avoids the case where the buffer would have
515 to be flushed at every write. */
516 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
517 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
518 && s
->buffer_offset
<= s
->logical_offset
519 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
521 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
522 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
528 /* Flush, and either fill the buffer with the new data, or if
529 the request is bigger than the buffer size, write directly
530 bypassing the buffer. */
532 if (nbyte
<= BUFFER_SIZE
/2)
534 memcpy (s
->buffer
, buf
, nbyte
);
535 s
->buffer_offset
= s
->logical_offset
;
540 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
)
542 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
544 s
->physical_offset
= s
->logical_offset
;
547 nbyte
= raw_write (s
, buf
, nbyte
);
548 s
->physical_offset
+= nbyte
;
551 s
->logical_offset
+= nbyte
;
552 /* Don't increment file_length if the file is non-seekable. */
553 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
554 s
->file_length
= s
->logical_offset
;
559 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
566 offset
+= s
->logical_offset
;
569 offset
+= s
->file_length
;
579 s
->logical_offset
= offset
;
584 buf_tell (unix_stream
* s
)
586 return s
->logical_offset
;
590 buf_truncate (unix_stream
* s
, gfc_offset length
)
594 if (buf_flush (s
) != 0)
596 r
= raw_truncate (s
, length
);
598 s
->file_length
= length
;
603 buf_close (unix_stream
* s
)
605 if (buf_flush (s
) != 0)
608 return raw_close (s
);
612 buf_init (unix_stream
* s
)
614 s
->st
.read
= (void *) buf_read
;
615 s
->st
.write
= (void *) buf_write
;
616 s
->st
.seek
= (void *) buf_seek
;
617 s
->st
.tell
= (void *) buf_tell
;
618 s
->st
.trunc
= (void *) buf_truncate
;
619 s
->st
.close
= (void *) buf_close
;
620 s
->st
.flush
= (void *) buf_flush
;
622 s
->buffer
= get_mem (BUFFER_SIZE
);
627 /*********************************************************************
628 memory stream functions - These are used for internal files
630 The idea here is that a single stream structure is created and all
631 requests must be satisfied from it. The location and size of the
632 buffer is the character variable supplied to the READ or WRITE
635 *********************************************************************/
638 mem_alloc_r (stream
* strm
, int * len
)
640 unix_stream
* s
= (unix_stream
*) strm
;
642 gfc_offset where
= s
->logical_offset
;
644 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
647 n
= s
->buffer_offset
+ s
->active
- where
;
651 s
->logical_offset
= where
+ *len
;
653 return s
->buffer
+ (where
- s
->buffer_offset
);
658 mem_alloc_r4 (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
) * 4;
678 mem_alloc_w (stream
* strm
, int * len
)
680 unix_stream
* s
= (unix_stream
*) strm
;
682 gfc_offset where
= s
->logical_offset
;
686 if (where
< s
->buffer_offset
)
689 if (m
> s
->file_length
)
692 s
->logical_offset
= m
;
694 return s
->buffer
+ (where
- s
->buffer_offset
);
699 mem_alloc_w4 (stream
* strm
, int * len
)
701 unix_stream
* s
= (unix_stream
*) strm
;
703 gfc_offset where
= s
->logical_offset
;
704 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
708 if (where
< s
->buffer_offset
)
711 if (m
> s
->file_length
)
714 s
->logical_offset
= m
;
715 return &result
[where
- s
->buffer_offset
];
719 /* Stream read function for character(kine=1) internal units. */
722 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
727 p
= mem_alloc_r (s
, &nb
);
738 /* Stream read function for chracter(kind=4) internal units. */
741 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
746 p
= mem_alloc_r (s
, &nb
);
757 /* Stream write function for character(kind=1) internal units. */
760 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
765 p
= mem_alloc_w (s
, &nb
);
776 /* Stream write function for character(kind=4) internal units. */
779 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
784 p
= mem_alloc_w4 (s
, &nw
);
788 *p
++ = (gfc_char4_t
) *((char *) buf
);
797 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
799 unix_stream
* s
= (unix_stream
*) strm
;
805 offset
+= s
->logical_offset
;
808 offset
+= s
->file_length
;
814 /* Note that for internal array I/O it's actually possible to have a
815 negative offset, so don't check for that. */
816 if (offset
> s
->file_length
)
822 s
->logical_offset
= offset
;
824 /* Returning < 0 is the error indicator for sseek(), so return 0 if
825 offset is negative. Thus if the return value is 0, the caller
826 has to use stell() to get the real value of logical_offset. */
834 mem_tell (stream
* s
)
836 return ((unix_stream
*)s
)->logical_offset
;
841 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
842 gfc_offset length
__attribute__ ((unused
)))
849 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
856 mem_close (unix_stream
* s
)
865 /*********************************************************************
866 Public functions -- A reimplementation of this module needs to
867 define functional equivalents of the following.
868 *********************************************************************/
870 /* open_internal()-- Returns a stream structure from a character(kind=1)
874 open_internal (char *base
, int length
, gfc_offset offset
)
878 s
= get_mem (sizeof (unix_stream
));
879 memset (s
, '\0', sizeof (unix_stream
));
882 s
->buffer_offset
= offset
;
884 s
->logical_offset
= 0;
885 s
->active
= s
->file_length
= length
;
887 s
->st
.close
= (void *) mem_close
;
888 s
->st
.seek
= (void *) mem_seek
;
889 s
->st
.tell
= (void *) mem_tell
;
890 s
->st
.trunc
= (void *) mem_truncate
;
891 s
->st
.read
= (void *) mem_read
;
892 s
->st
.write
= (void *) mem_write
;
893 s
->st
.flush
= (void *) mem_flush
;
898 /* open_internal4()-- Returns a stream structure from a character(kind=4)
902 open_internal4 (char *base
, int length
, gfc_offset offset
)
906 s
= get_mem (sizeof (unix_stream
));
907 memset (s
, '\0', sizeof (unix_stream
));
910 s
->buffer_offset
= offset
;
912 s
->logical_offset
= 0;
913 s
->active
= s
->file_length
= length
;
915 s
->st
.close
= (void *) mem_close
;
916 s
->st
.seek
= (void *) mem_seek
;
917 s
->st
.tell
= (void *) mem_tell
;
918 s
->st
.trunc
= (void *) mem_truncate
;
919 s
->st
.read
= (void *) mem_read4
;
920 s
->st
.write
= (void *) mem_write4
;
921 s
->st
.flush
= (void *) mem_flush
;
927 /* fd_to_stream()-- Given an open file descriptor, build a stream
931 fd_to_stream (int fd
)
936 s
= get_mem (sizeof (unix_stream
));
937 memset (s
, '\0', sizeof (unix_stream
));
940 s
->buffer_offset
= 0;
941 s
->physical_offset
= 0;
942 s
->logical_offset
= 0;
944 /* Get the current length of the file. */
946 fstat (fd
, &statbuf
);
948 s
->st_dev
= statbuf
.st_dev
;
949 s
->st_ino
= statbuf
.st_ino
;
950 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
952 if (S_ISREG (statbuf
.st_mode
))
953 s
->file_length
= statbuf
.st_size
;
954 else if (S_ISBLK (statbuf
.st_mode
))
956 /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)? */
957 gfc_offset cur
= lseek (fd
, 0, SEEK_CUR
);
958 s
->file_length
= lseek (fd
, 0, SEEK_END
);
959 lseek (fd
, cur
, SEEK_SET
);
964 if (!(S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
965 || options
.all_unbuffered
966 ||(options
.unbuffered_preconnected
&&
967 (s
->fd
== STDIN_FILENO
968 || s
->fd
== STDOUT_FILENO
969 || s
->fd
== STDERR_FILENO
))
979 /* Given the Fortran unit number, convert it to a C file descriptor. */
982 unit_to_fd (int unit
)
987 us
= find_unit (unit
);
991 fd
= ((unix_stream
*) us
->s
)->fd
;
997 /* unpack_filename()-- Given a fortran string and a pointer to a
998 * buffer that is PATH_MAX characters, convert the fortran string to a
999 * C string in the buffer. Returns nonzero if this is not possible. */
1002 unpack_filename (char *cstring
, const char *fstring
, int len
)
1004 if (fstring
== NULL
)
1006 len
= fstrlen (fstring
, len
);
1007 if (len
>= PATH_MAX
)
1010 memmove (cstring
, fstring
, len
);
1011 cstring
[len
] = '\0';
1017 /* tempfile()-- Generate a temporary filename for a scratch file and
1018 * open it. mkstemp() opens the file for reading and writing, but the
1019 * library mode prevents anything that is not allowed. The descriptor
1020 * is returned, which is -1 on error. The template is pointed to by
1021 * opp->file, which is copied into the unit structure
1022 * and freed later. */
1025 tempfile (st_parameter_open
*opp
)
1027 const char *tempdir
;
1029 const char *slash
= "/";
1032 tempdir
= getenv ("GFORTRAN_TMPDIR");
1034 if (tempdir
== NULL
)
1036 char buffer
[MAX_PATH
+ 1];
1038 ret
= GetTempPath (MAX_PATH
, buffer
);
1039 /* If we are not able to get a temp-directory, we use
1040 current directory. */
1041 if (ret
> MAX_PATH
|| !ret
)
1045 tempdir
= strdup (buffer
);
1048 if (tempdir
== NULL
)
1049 tempdir
= getenv ("TMP");
1050 if (tempdir
== NULL
)
1051 tempdir
= getenv ("TEMP");
1052 if (tempdir
== NULL
)
1053 tempdir
= DEFAULT_TEMPDIR
;
1055 /* Check for special case that tempdir contains slash
1056 or backslash at end. */
1057 if (*tempdir
== 0 || tempdir
[strlen (tempdir
) - 1] == '/'
1059 || tempdir
[strlen (tempdir
) - 1] == '\\'
1064 template = get_mem (strlen (tempdir
) + 20);
1067 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir
, slash
);
1069 fd
= mkstemp (template);
1071 #else /* HAVE_MKSTEMP */
1075 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir
, slash
);
1076 if (!mktemp (template))
1078 #if defined(HAVE_CRLF) && defined(O_BINARY)
1079 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1080 S_IREAD
| S_IWRITE
);
1082 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1085 while (fd
== -1 && errno
== EEXIST
);
1086 #endif /* HAVE_MKSTEMP */
1088 opp
->file
= template;
1089 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1095 /* regular_file()-- Open a regular file.
1096 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1097 * unless an error occurs.
1098 * Returns the descriptor, which is less than zero on error. */
1101 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1103 char path
[PATH_MAX
+ 1];
1109 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1111 errno
= ENOENT
; /* Fake an OS error */
1116 if (opp
->file_len
== 7)
1118 if (strncmp (path
, "CONOUT$", 7) == 0
1119 || strncmp (path
, "CONERR$", 7) == 0)
1121 fd
= open ("/dev/conout", O_WRONLY
);
1122 flags
->action
= ACTION_WRITE
;
1127 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1129 fd
= open ("/dev/conin", O_RDONLY
);
1130 flags
->action
= ACTION_READ
;
1137 if (opp
->file_len
== 7)
1139 if (strncmp (path
, "CONOUT$", 7) == 0
1140 || strncmp (path
, "CONERR$", 7) == 0)
1142 fd
= open ("CONOUT$", O_WRONLY
);
1143 flags
->action
= ACTION_WRITE
;
1148 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1150 fd
= open ("CONIN$", O_RDONLY
);
1151 flags
->action
= ACTION_READ
;
1158 switch (flags
->action
)
1168 case ACTION_READWRITE
:
1169 case ACTION_UNSPECIFIED
:
1174 internal_error (&opp
->common
, "regular_file(): Bad action");
1177 switch (flags
->status
)
1180 crflag
= O_CREAT
| O_EXCL
;
1183 case STATUS_OLD
: /* open will fail if the file does not exist*/
1187 case STATUS_UNKNOWN
:
1188 case STATUS_SCRATCH
:
1192 case STATUS_REPLACE
:
1193 crflag
= O_CREAT
| O_TRUNC
;
1197 internal_error (&opp
->common
, "regular_file(): Bad status");
1200 /* rwflag |= O_LARGEFILE; */
1202 #if defined(HAVE_CRLF) && defined(O_BINARY)
1206 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1207 fd
= open (path
, rwflag
| crflag
, mode
);
1208 if (flags
->action
!= ACTION_UNSPECIFIED
)
1213 flags
->action
= ACTION_READWRITE
;
1216 if (errno
!= EACCES
&& errno
!= EROFS
)
1219 /* retry for read-only access */
1221 fd
= open (path
, rwflag
| crflag
, mode
);
1224 flags
->action
= ACTION_READ
;
1225 return fd
; /* success */
1228 if (errno
!= EACCES
)
1229 return fd
; /* failure */
1231 /* retry for write-only access */
1233 fd
= open (path
, rwflag
| crflag
, mode
);
1236 flags
->action
= ACTION_WRITE
;
1237 return fd
; /* success */
1239 return fd
; /* failure */
1243 /* open_external()-- Open an external file, unix specific version.
1244 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1245 * Returns NULL on operating system error. */
1248 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1252 if (flags
->status
== STATUS_SCRATCH
)
1254 fd
= tempfile (opp
);
1255 if (flags
->action
== ACTION_UNSPECIFIED
)
1256 flags
->action
= ACTION_READWRITE
;
1258 #if HAVE_UNLINK_OPEN_FILE
1259 /* We can unlink scratch files now and it will go away when closed. */
1266 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1268 fd
= regular_file (opp
, flags
);
1275 return fd_to_stream (fd
);
1279 /* input_stream()-- Return a stream pointer to the default input stream.
1280 * Called on initialization. */
1285 return fd_to_stream (STDIN_FILENO
);
1289 /* output_stream()-- Return a stream pointer to the default output stream.
1290 * Called on initialization. */
1293 output_stream (void)
1297 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1298 setmode (STDOUT_FILENO
, O_BINARY
);
1301 s
= fd_to_stream (STDOUT_FILENO
);
1306 /* error_stream()-- Return a stream pointer to the default error stream.
1307 * Called on initialization. */
1314 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1315 setmode (STDERR_FILENO
, O_BINARY
);
1318 s
= fd_to_stream (STDERR_FILENO
);
1323 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1324 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1325 is big enough to completely fill a 80x25 terminal, so it shuld be
1326 OK. We use a direct write() because it is simpler and least likely
1327 to be clobbered by memory corruption. Writing an error message
1328 longer than that is an error. */
1330 #define ST_VPRINTF_SIZE 2048
1333 st_vprintf (const char *format
, va_list ap
)
1335 static char buffer
[ST_VPRINTF_SIZE
];
1339 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1340 #ifdef HAVE_VSNPRINTF
1341 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1343 written
= vsprintf(buffer
, format
, ap
);
1345 if (written
>= ST_VPRINTF_SIZE
-1)
1347 /* The error message was longer than our buffer. Ouch. Because
1348 we may have messed up things badly, report the error and
1350 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1351 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1352 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1354 #undef ERROR_MESSAGE
1359 written
= write (fd
, buffer
, written
);
1363 /* st_printf()-- printf() function for error output. This just calls
1364 st_vprintf() to do the actual work. */
1367 st_printf (const char *format
, ...)
1371 va_start (ap
, format
);
1372 written
= st_vprintf(format
, ap
);
1378 /* compare_file_filename()-- Given an open stream and a fortran string
1379 * that is a filename, figure out if the file is the same as the
1383 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1385 char path
[PATH_MAX
+ 1];
1387 #ifdef HAVE_WORKING_STAT
1395 if (unpack_filename (path
, name
, len
))
1396 return 0; /* Can't be the same */
1398 /* If the filename doesn't exist, then there is no match with the
1401 if (stat (path
, &st
) < 0)
1404 #ifdef HAVE_WORKING_STAT
1405 s
= (unix_stream
*) (u
->s
);
1406 return (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1410 /* We try to match files by a unique ID. On some filesystems (network
1411 fs and FAT), we can't generate this unique ID, and will simply compare
1413 id1
= id_from_path (path
);
1414 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1416 return (id1
== id2
);
1419 if (len
!= u
->file_len
)
1421 return (memcmp(path
, u
->file
, len
) == 0);
1426 #ifdef HAVE_WORKING_STAT
1427 # define FIND_FILE0_DECL gfstat_t *st
1428 # define FIND_FILE0_ARGS st
1430 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1431 # define FIND_FILE0_ARGS id, file, file_len
1434 /* find_file0()-- Recursive work function for find_file() */
1437 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1440 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1447 #ifdef HAVE_WORKING_STAT
1450 unix_stream
*s
= (unix_stream
*) (u
->s
);
1451 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1456 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1463 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1467 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1471 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1479 /* find_file()-- Take the current filename and see if there is a unit
1480 * that has the file already open. Returns a pointer to the unit if so. */
1483 find_file (const char *file
, gfc_charlen_type file_len
)
1485 char path
[PATH_MAX
+ 1];
1488 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1492 if (unpack_filename (path
, file
, file_len
))
1495 if (stat (path
, &st
[0]) < 0)
1498 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1499 id
= id_from_path (path
);
1502 __gthread_mutex_lock (&unit_lock
);
1504 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1508 if (! __gthread_mutex_trylock (&u
->lock
))
1510 /* assert (u->closed == 0); */
1511 __gthread_mutex_unlock (&unit_lock
);
1515 inc_waiting_locked (u
);
1517 __gthread_mutex_unlock (&unit_lock
);
1520 __gthread_mutex_lock (&u
->lock
);
1523 __gthread_mutex_lock (&unit_lock
);
1524 __gthread_mutex_unlock (&u
->lock
);
1525 if (predec_waiting_locked (u
) == 0)
1530 dec_waiting_unlocked (u
);
1536 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1540 if (u
->unit_number
> min_unit
)
1542 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1546 if (u
->unit_number
>= min_unit
)
1548 if (__gthread_mutex_trylock (&u
->lock
))
1552 __gthread_mutex_unlock (&u
->lock
);
1560 flush_all_units (void)
1565 __gthread_mutex_lock (&unit_lock
);
1568 u
= flush_all_units_1 (unit_root
, min_unit
);
1570 inc_waiting_locked (u
);
1571 __gthread_mutex_unlock (&unit_lock
);
1575 __gthread_mutex_lock (&u
->lock
);
1577 min_unit
= u
->unit_number
+ 1;
1582 __gthread_mutex_lock (&unit_lock
);
1583 __gthread_mutex_unlock (&u
->lock
);
1584 (void) predec_waiting_locked (u
);
1588 __gthread_mutex_lock (&unit_lock
);
1589 __gthread_mutex_unlock (&u
->lock
);
1590 if (predec_waiting_locked (u
) == 0)
1598 /* delete_file()-- Given a unit structure, delete the file associated
1599 * with the unit. Returns nonzero if something went wrong. */
1602 delete_file (gfc_unit
* u
)
1604 char path
[PATH_MAX
+ 1];
1606 if (unpack_filename (path
, u
->file
, u
->file_len
))
1607 { /* Shouldn't be possible */
1612 return unlink (path
);
1616 /* file_exists()-- Returns nonzero if the current filename exists on
1620 file_exists (const char *file
, gfc_charlen_type file_len
)
1622 char path
[PATH_MAX
+ 1];
1624 if (unpack_filename (path
, file
, file_len
))
1627 return !(access (path
, F_OK
));
1631 /* file_size()-- Returns the size of the file. */
1634 file_size (const char *file
, gfc_charlen_type file_len
)
1636 char path
[PATH_MAX
+ 1];
1639 if (unpack_filename (path
, file
, file_len
))
1642 if (stat (path
, &statbuf
) < 0)
1645 return (GFC_IO_INT
) statbuf
.st_size
;
1648 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1650 /* inquire_sequential()-- Given a fortran string, determine if the
1651 * file is suitable for sequential access. Returns a C-style
1655 inquire_sequential (const char *string
, int len
)
1657 char path
[PATH_MAX
+ 1];
1660 if (string
== NULL
||
1661 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1664 if (S_ISREG (statbuf
.st_mode
) ||
1665 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1668 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1675 /* inquire_direct()-- Given a fortran string, determine if the file is
1676 * suitable for direct access. Returns a C-style string. */
1679 inquire_direct (const char *string
, int len
)
1681 char path
[PATH_MAX
+ 1];
1684 if (string
== NULL
||
1685 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1688 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1691 if (S_ISDIR (statbuf
.st_mode
) ||
1692 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1699 /* inquire_formatted()-- Given a fortran string, determine if the file
1700 * is suitable for formatted form. Returns a C-style string. */
1703 inquire_formatted (const char *string
, int len
)
1705 char path
[PATH_MAX
+ 1];
1708 if (string
== NULL
||
1709 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1712 if (S_ISREG (statbuf
.st_mode
) ||
1713 S_ISBLK (statbuf
.st_mode
) ||
1714 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1717 if (S_ISDIR (statbuf
.st_mode
))
1724 /* inquire_unformatted()-- Given a fortran string, determine if the file
1725 * is suitable for unformatted form. Returns a C-style string. */
1728 inquire_unformatted (const char *string
, int len
)
1730 return inquire_formatted (string
, len
);
1734 /* inquire_access()-- Given a fortran string, determine if the file is
1735 * suitable for access. */
1738 inquire_access (const char *string
, int len
, int mode
)
1740 char path
[PATH_MAX
+ 1];
1742 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1743 access (path
, mode
) < 0)
1750 /* inquire_read()-- Given a fortran string, determine if the file is
1751 * suitable for READ access. */
1754 inquire_read (const char *string
, int len
)
1756 return inquire_access (string
, len
, R_OK
);
1760 /* inquire_write()-- Given a fortran string, determine if the file is
1761 * suitable for READ access. */
1764 inquire_write (const char *string
, int len
)
1766 return inquire_access (string
, len
, W_OK
);
1770 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1771 * suitable for read and write access. */
1774 inquire_readwrite (const char *string
, int len
)
1776 return inquire_access (string
, len
, R_OK
| W_OK
);
1780 /* file_length()-- Return the file length in bytes, -1 if unknown */
1783 file_length (stream
* s
)
1785 gfc_offset curr
, end
;
1786 if (!is_seekable (s
))
1791 end
= sseek (s
, 0, SEEK_END
);
1792 sseek (s
, curr
, SEEK_SET
);
1797 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1801 is_seekable (stream
*s
)
1803 /* By convention, if file_length == -1, the file is not
1805 return ((unix_stream
*) s
)->file_length
!=-1;
1809 /* is_special()-- Return nonzero if the stream is not a regular file. */
1812 is_special (stream
*s
)
1814 return ((unix_stream
*) s
)->special_file
;
1819 stream_isatty (stream
*s
)
1821 return isatty (((unix_stream
*) s
)->fd
);
1826 stream_ttyname (stream
*s
)
1828 return ttyname (((unix_stream
*) s
)->fd
);
1831 stream_ttyname (stream
*s
__attribute__ ((unused
)))
1839 /* How files are stored: This is an operating-system specific issue,
1840 and therefore belongs here. There are three cases to consider.
1843 Records are written as block of bytes corresponding to the record
1844 length of the file. This goes for both formatted and unformatted
1845 records. Positioning is done explicitly for each data transfer,
1846 so positioning is not much of an issue.
1848 Sequential Formatted:
1849 Records are separated by newline characters. The newline character
1850 is prohibited from appearing in a string. If it does, this will be
1851 messed up on the next read. End of file is also the end of a record.
1853 Sequential Unformatted:
1854 In this case, we are merely copying bytes to and from main storage,
1855 yet we need to keep track of varying record lengths. We adopt
1856 the solution used by f2c. Each record contains a pair of length
1859 Length of record n in bytes
1861 Length of record n in bytes
1863 Length of record n+1 in bytes
1865 Length of record n+1 in bytes
1867 The length is stored at the end of a record to allow backspacing to the
1868 previous record. Between data transfer statements, the file pointer
1869 is left pointing to the first length of the current record.
1871 ENDFILE records are never explicitly stored.