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
)
149 if ((mode
& R_OK
) && (fd
= open (path
, O_RDONLY
)) < 0)
153 if ((mode
& W_OK
) && (fd
= open (path
, O_WRONLY
)) < 0)
160 return stat (path
, &st
);
167 #define access fallback_access
171 /* Unix and internal stream I/O module */
173 static const int BUFFER_SIZE
= 8192;
179 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
180 gfc_offset physical_offset
; /* Current physical file offset */
181 gfc_offset logical_offset
; /* Current logical file offset */
182 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
184 char *buffer
; /* Pointer to the buffer. */
185 int fd
; /* The POSIX file descriptor. */
187 int active
; /* Length of valid bytes in the buffer */
189 int ndirty
; /* Dirty bytes starting at buffer_offset */
191 int special_file
; /* =1 if the fd refers to a special file */
193 /* Cached stat(2) values. */
200 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
201 * standard descriptors, returning a non-standard descriptor. If the
202 * user specifies that system errors should go to standard output,
203 * then closes standard output, we don't want the system errors to a
204 * file that has been given file descriptor 1 or 0. We want to send
205 * the error to the invalid descriptor. */
211 int input
, output
, error
;
213 input
= output
= error
= 0;
215 /* Unix allocates the lowest descriptors first, so a loop is not
216 required, but this order is. */
217 if (fd
== STDIN_FILENO
)
222 if (fd
== STDOUT_FILENO
)
227 if (fd
== STDERR_FILENO
)
234 close (STDIN_FILENO
);
236 close (STDOUT_FILENO
);
238 close (STDERR_FILENO
);
245 /* If the stream corresponds to a preconnected unit, we flush the
246 corresponding C stream. This is bugware for mixed C-Fortran codes
247 where the C code doesn't flush I/O before returning. */
249 flush_if_preconnected (stream
* s
)
253 fd
= ((unix_stream
*) s
)->fd
;
254 if (fd
== STDIN_FILENO
)
256 else if (fd
== STDOUT_FILENO
)
258 else if (fd
== STDERR_FILENO
)
263 /********************************************************************
264 Raw I/O functions (read, write, seek, tell, truncate, close).
266 These functions wrap the basic POSIX I/O syscalls. Any deviation in
267 semantics is a bug, except the following: write restarts in case
268 of being interrupted by a signal, and as the first argument the
269 functions take the unix_stream struct rather than an integer file
270 descriptor. Also, for POSIX read() and write() a nbyte argument larger
271 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
272 than size_t as for POSIX read/write.
273 *********************************************************************/
276 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
282 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
284 /* For read we can't do I/O in a loop like raw_write does, because
285 that will break applications that wait for interactive I/O. */
286 return read (s
->fd
, buf
, nbyte
);
290 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
292 ssize_t trans
, bytes_left
;
296 buf_st
= (char *) buf
;
298 /* We must write in a loop since some systems don't restart system
299 calls in case of a signal. */
300 while (bytes_left
> 0)
302 trans
= write (s
->fd
, buf_st
, bytes_left
);
314 return nbyte
- bytes_left
;
318 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
320 return lseek (s
->fd
, offset
, whence
);
324 raw_tell (unix_stream
* s
)
326 return lseek (s
->fd
, 0, SEEK_CUR
);
330 raw_truncate (unix_stream
* s
, gfc_offset length
)
341 h
= (HANDLE
) _get_osfhandle (s
->fd
);
342 if (h
== INVALID_HANDLE_VALUE
)
347 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
350 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
352 if (!SetEndOfFile (h
))
357 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
361 lseek (s
->fd
, cur
, SEEK_SET
);
363 #elif defined HAVE_FTRUNCATE
364 return ftruncate (s
->fd
, length
);
365 #elif defined HAVE_CHSIZE
366 return chsize (s
->fd
, length
);
368 runtime_error ("required ftruncate or chsize support not present");
374 raw_close (unix_stream
* s
)
378 if (s
->fd
!= STDOUT_FILENO
379 && s
->fd
!= STDERR_FILENO
380 && s
->fd
!= STDIN_FILENO
)
381 retval
= close (s
->fd
);
389 raw_init (unix_stream
* s
)
391 s
->st
.read
= (void *) raw_read
;
392 s
->st
.write
= (void *) raw_write
;
393 s
->st
.seek
= (void *) raw_seek
;
394 s
->st
.tell
= (void *) raw_tell
;
395 s
->st
.trunc
= (void *) raw_truncate
;
396 s
->st
.close
= (void *) raw_close
;
397 s
->st
.flush
= (void *) raw_flush
;
404 /*********************************************************************
405 Buffered I/O functions. These functions have the same semantics as the
406 raw I/O functions above, except that they are buffered in order to
407 improve performance. The buffer must be flushed when switching from
408 reading to writing and vice versa.
409 *********************************************************************/
412 buf_flush (unix_stream
* s
)
416 /* Flushing in read mode means discarding read bytes. */
422 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
423 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
426 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
428 s
->physical_offset
= s
->buffer_offset
+ writelen
;
430 /* Don't increment file_length if the file is non-seekable. */
431 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
432 s
->file_length
= s
->physical_offset
;
434 s
->ndirty
-= writelen
;
446 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
449 s
->buffer_offset
= s
->logical_offset
;
451 /* Is the data we want in the buffer? */
452 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
453 && s
->buffer_offset
<= s
->logical_offset
)
454 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
457 /* First copy the active bytes if applicable, then read the rest
458 either directly or filling the buffer. */
461 ssize_t to_read
, did_read
;
462 gfc_offset new_logical
;
465 if (s
->logical_offset
>= s
->buffer_offset
466 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
468 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
469 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
473 /* At this point we consider all bytes in the buffer discarded. */
474 to_read
= nbyte
- nread
;
475 new_logical
= s
->logical_offset
+ nread
;
476 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
477 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
479 s
->buffer_offset
= s
->physical_offset
= new_logical
;
480 if (to_read
<= BUFFER_SIZE
/2)
482 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
483 s
->physical_offset
+= did_read
;
484 s
->active
= did_read
;
485 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
486 memcpy (p
, s
->buffer
, did_read
);
490 did_read
= raw_read (s
, p
, to_read
);
491 s
->physical_offset
+= did_read
;
494 nbyte
= did_read
+ nread
;
496 s
->logical_offset
+= nbyte
;
501 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
504 s
->buffer_offset
= s
->logical_offset
;
506 /* Does the data fit into the buffer? As a special case, if the
507 buffer is empty and the request is bigger than BUFFER_SIZE/2,
508 write directly. This avoids the case where the buffer would have
509 to be flushed at every write. */
510 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
511 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
512 && s
->buffer_offset
<= s
->logical_offset
513 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
515 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
516 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
522 /* Flush, and either fill the buffer with the new data, or if
523 the request is bigger than the buffer size, write directly
524 bypassing the buffer. */
526 if (nbyte
<= BUFFER_SIZE
/2)
528 memcpy (s
->buffer
, buf
, nbyte
);
529 s
->buffer_offset
= s
->logical_offset
;
534 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
)
536 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
538 s
->physical_offset
= s
->logical_offset
;
541 nbyte
= raw_write (s
, buf
, nbyte
);
542 s
->physical_offset
+= nbyte
;
545 s
->logical_offset
+= nbyte
;
546 /* Don't increment file_length if the file is non-seekable. */
547 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
548 s
->file_length
= s
->logical_offset
;
553 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
560 offset
+= s
->logical_offset
;
563 offset
+= s
->file_length
;
573 s
->logical_offset
= offset
;
578 buf_tell (unix_stream
* s
)
580 return s
->logical_offset
;
584 buf_truncate (unix_stream
* s
, gfc_offset length
)
588 if (buf_flush (s
) != 0)
590 r
= raw_truncate (s
, length
);
592 s
->file_length
= length
;
597 buf_close (unix_stream
* s
)
599 if (buf_flush (s
) != 0)
602 return raw_close (s
);
606 buf_init (unix_stream
* s
)
608 s
->st
.read
= (void *) buf_read
;
609 s
->st
.write
= (void *) buf_write
;
610 s
->st
.seek
= (void *) buf_seek
;
611 s
->st
.tell
= (void *) buf_tell
;
612 s
->st
.trunc
= (void *) buf_truncate
;
613 s
->st
.close
= (void *) buf_close
;
614 s
->st
.flush
= (void *) buf_flush
;
616 s
->buffer
= get_mem (BUFFER_SIZE
);
621 /*********************************************************************
622 memory stream functions - These are used for internal files
624 The idea here is that a single stream structure is created and all
625 requests must be satisfied from it. The location and size of the
626 buffer is the character variable supplied to the READ or WRITE
629 *********************************************************************/
632 mem_alloc_r (stream
* strm
, int * len
)
634 unix_stream
* s
= (unix_stream
*) strm
;
636 gfc_offset where
= s
->logical_offset
;
638 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
641 n
= s
->buffer_offset
+ s
->active
- where
;
645 s
->logical_offset
= where
+ *len
;
647 return s
->buffer
+ (where
- s
->buffer_offset
);
652 mem_alloc_r4 (stream
* strm
, int * len
)
654 unix_stream
* s
= (unix_stream
*) strm
;
656 gfc_offset where
= s
->logical_offset
;
658 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
661 n
= s
->buffer_offset
+ s
->active
- where
;
665 s
->logical_offset
= where
+ *len
;
667 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
672 mem_alloc_w (stream
* strm
, int * len
)
674 unix_stream
* s
= (unix_stream
*) strm
;
676 gfc_offset where
= s
->logical_offset
;
680 if (where
< s
->buffer_offset
)
683 if (m
> s
->file_length
)
686 s
->logical_offset
= m
;
688 return s
->buffer
+ (where
- s
->buffer_offset
);
693 mem_alloc_w4 (stream
* strm
, int * len
)
695 unix_stream
* s
= (unix_stream
*) strm
;
697 gfc_offset where
= s
->logical_offset
;
698 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
702 if (where
< s
->buffer_offset
)
705 if (m
> s
->file_length
)
708 s
->logical_offset
= m
;
709 return &result
[where
- s
->buffer_offset
];
713 /* Stream read function for character(kine=1) internal units. */
716 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
721 p
= mem_alloc_r (s
, &nb
);
732 /* Stream read function for chracter(kind=4) internal units. */
735 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
740 p
= mem_alloc_r (s
, &nb
);
751 /* Stream write function for character(kind=1) internal units. */
754 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
759 p
= mem_alloc_w (s
, &nb
);
770 /* Stream write function for character(kind=4) internal units. */
773 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
778 p
= mem_alloc_w4 (s
, &nw
);
782 *p
++ = (gfc_char4_t
) *((char *) buf
);
791 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
793 unix_stream
* s
= (unix_stream
*) strm
;
799 offset
+= s
->logical_offset
;
802 offset
+= s
->file_length
;
808 /* Note that for internal array I/O it's actually possible to have a
809 negative offset, so don't check for that. */
810 if (offset
> s
->file_length
)
816 s
->logical_offset
= offset
;
818 /* Returning < 0 is the error indicator for sseek(), so return 0 if
819 offset is negative. Thus if the return value is 0, the caller
820 has to use stell() to get the real value of logical_offset. */
828 mem_tell (stream
* s
)
830 return ((unix_stream
*)s
)->logical_offset
;
835 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
836 gfc_offset length
__attribute__ ((unused
)))
843 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
850 mem_close (unix_stream
* s
)
859 /*********************************************************************
860 Public functions -- A reimplementation of this module needs to
861 define functional equivalents of the following.
862 *********************************************************************/
864 /* open_internal()-- Returns a stream structure from a character(kind=1)
868 open_internal (char *base
, int length
, gfc_offset offset
)
872 s
= get_mem (sizeof (unix_stream
));
873 memset (s
, '\0', sizeof (unix_stream
));
876 s
->buffer_offset
= offset
;
878 s
->logical_offset
= 0;
879 s
->active
= s
->file_length
= length
;
881 s
->st
.close
= (void *) mem_close
;
882 s
->st
.seek
= (void *) mem_seek
;
883 s
->st
.tell
= (void *) mem_tell
;
884 s
->st
.trunc
= (void *) mem_truncate
;
885 s
->st
.read
= (void *) mem_read
;
886 s
->st
.write
= (void *) mem_write
;
887 s
->st
.flush
= (void *) mem_flush
;
892 /* open_internal4()-- Returns a stream structure from a character(kind=4)
896 open_internal4 (char *base
, int length
, gfc_offset offset
)
900 s
= get_mem (sizeof (unix_stream
));
901 memset (s
, '\0', sizeof (unix_stream
));
904 s
->buffer_offset
= offset
;
906 s
->logical_offset
= 0;
907 s
->active
= s
->file_length
= length
;
909 s
->st
.close
= (void *) mem_close
;
910 s
->st
.seek
= (void *) mem_seek
;
911 s
->st
.tell
= (void *) mem_tell
;
912 s
->st
.trunc
= (void *) mem_truncate
;
913 s
->st
.read
= (void *) mem_read4
;
914 s
->st
.write
= (void *) mem_write4
;
915 s
->st
.flush
= (void *) mem_flush
;
921 /* fd_to_stream()-- Given an open file descriptor, build a stream
925 fd_to_stream (int fd
)
930 s
= get_mem (sizeof (unix_stream
));
931 memset (s
, '\0', sizeof (unix_stream
));
934 s
->buffer_offset
= 0;
935 s
->physical_offset
= 0;
936 s
->logical_offset
= 0;
938 /* Get the current length of the file. */
940 fstat (fd
, &statbuf
);
942 s
->st_dev
= statbuf
.st_dev
;
943 s
->st_ino
= statbuf
.st_ino
;
944 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
946 if (S_ISREG (statbuf
.st_mode
))
947 s
->file_length
= statbuf
.st_size
;
948 else if (S_ISBLK (statbuf
.st_mode
))
950 /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)? */
951 gfc_offset cur
= lseek (fd
, 0, SEEK_CUR
);
952 s
->file_length
= lseek (fd
, 0, SEEK_END
);
953 lseek (fd
, cur
, SEEK_SET
);
958 if (!(S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
959 || options
.all_unbuffered
960 ||(options
.unbuffered_preconnected
&&
961 (s
->fd
== STDIN_FILENO
962 || s
->fd
== STDOUT_FILENO
963 || s
->fd
== STDERR_FILENO
))
973 /* Given the Fortran unit number, convert it to a C file descriptor. */
976 unit_to_fd (int unit
)
981 us
= find_unit (unit
);
985 fd
= ((unix_stream
*) us
->s
)->fd
;
991 /* unpack_filename()-- Given a fortran string and a pointer to a
992 * buffer that is PATH_MAX characters, convert the fortran string to a
993 * C string in the buffer. Returns nonzero if this is not possible. */
996 unpack_filename (char *cstring
, const char *fstring
, int len
)
1000 len
= fstrlen (fstring
, len
);
1001 if (len
>= PATH_MAX
)
1004 memmove (cstring
, fstring
, len
);
1005 cstring
[len
] = '\0';
1011 /* tempfile()-- Generate a temporary filename for a scratch file and
1012 * open it. mkstemp() opens the file for reading and writing, but the
1013 * library mode prevents anything that is not allowed. The descriptor
1014 * is returned, which is -1 on error. The template is pointed to by
1015 * opp->file, which is copied into the unit structure
1016 * and freed later. */
1019 tempfile (st_parameter_open
*opp
)
1021 const char *tempdir
;
1023 const char *slash
= "/";
1027 #ifndef HAVE_MKSTEMP
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
;
1056 /* Check for special case that tempdir contains slash
1057 or backslash at end. */
1058 tempdirlen
= strlen (tempdir
);
1059 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1061 || tempdir
[tempdirlen
- 1] == '\\'
1066 // Take care that the template is longer in the mktemp() branch.
1067 template = get_mem (tempdirlen
+ 23);
1070 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir
, slash
);
1072 fd
= mkstemp (template);
1074 #else /* HAVE_MKSTEMP */
1077 slashlen
= strlen (slash
);
1080 sprintf (template, "%s%sgfortrantmpaaaXXXXXX", tempdir
, slash
);
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
,
1102 S_IREAD
| S_IWRITE
);
1104 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1107 while (fd
== -1 && errno
== EEXIST
);
1108 #endif /* HAVE_MKSTEMP */
1110 opp
->file
= template;
1111 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1117 /* regular_file()-- Open a regular file.
1118 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1119 * unless an error occurs.
1120 * Returns the descriptor, which is less than zero on error. */
1123 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1125 char path
[PATH_MAX
+ 1];
1131 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1133 errno
= ENOENT
; /* Fake an OS error */
1138 if (opp
->file_len
== 7)
1140 if (strncmp (path
, "CONOUT$", 7) == 0
1141 || strncmp (path
, "CONERR$", 7) == 0)
1143 fd
= open ("/dev/conout", O_WRONLY
);
1144 flags
->action
= ACTION_WRITE
;
1149 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1151 fd
= open ("/dev/conin", O_RDONLY
);
1152 flags
->action
= ACTION_READ
;
1159 if (opp
->file_len
== 7)
1161 if (strncmp (path
, "CONOUT$", 7) == 0
1162 || strncmp (path
, "CONERR$", 7) == 0)
1164 fd
= open ("CONOUT$", O_WRONLY
);
1165 flags
->action
= ACTION_WRITE
;
1170 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1172 fd
= open ("CONIN$", O_RDONLY
);
1173 flags
->action
= ACTION_READ
;
1180 switch (flags
->action
)
1190 case ACTION_READWRITE
:
1191 case ACTION_UNSPECIFIED
:
1196 internal_error (&opp
->common
, "regular_file(): Bad action");
1199 switch (flags
->status
)
1202 crflag
= O_CREAT
| O_EXCL
;
1205 case STATUS_OLD
: /* open will fail if the file does not exist*/
1209 case STATUS_UNKNOWN
:
1210 case STATUS_SCRATCH
:
1214 case STATUS_REPLACE
:
1215 crflag
= O_CREAT
| O_TRUNC
;
1219 internal_error (&opp
->common
, "regular_file(): Bad status");
1222 /* rwflag |= O_LARGEFILE; */
1224 #if defined(HAVE_CRLF) && defined(O_BINARY)
1228 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1229 fd
= open (path
, rwflag
| crflag
, mode
);
1230 if (flags
->action
!= ACTION_UNSPECIFIED
)
1235 flags
->action
= ACTION_READWRITE
;
1238 if (errno
!= EACCES
&& errno
!= EROFS
)
1241 /* retry for read-only access */
1243 fd
= open (path
, rwflag
| crflag
, mode
);
1246 flags
->action
= ACTION_READ
;
1247 return fd
; /* success */
1250 if (errno
!= EACCES
)
1251 return fd
; /* failure */
1253 /* retry for write-only access */
1255 fd
= open (path
, rwflag
| crflag
, mode
);
1258 flags
->action
= ACTION_WRITE
;
1259 return fd
; /* success */
1261 return fd
; /* failure */
1265 /* open_external()-- Open an external file, unix specific version.
1266 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1267 * Returns NULL on operating system error. */
1270 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1274 if (flags
->status
== STATUS_SCRATCH
)
1276 fd
= tempfile (opp
);
1277 if (flags
->action
== ACTION_UNSPECIFIED
)
1278 flags
->action
= ACTION_READWRITE
;
1280 #if HAVE_UNLINK_OPEN_FILE
1281 /* We can unlink scratch files now and it will go away when closed. */
1288 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1290 fd
= regular_file (opp
, flags
);
1297 return fd_to_stream (fd
);
1301 /* input_stream()-- Return a stream pointer to the default input stream.
1302 * Called on initialization. */
1307 return fd_to_stream (STDIN_FILENO
);
1311 /* output_stream()-- Return a stream pointer to the default output stream.
1312 * Called on initialization. */
1315 output_stream (void)
1319 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1320 setmode (STDOUT_FILENO
, O_BINARY
);
1323 s
= fd_to_stream (STDOUT_FILENO
);
1328 /* error_stream()-- Return a stream pointer to the default error stream.
1329 * Called on initialization. */
1336 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1337 setmode (STDERR_FILENO
, O_BINARY
);
1340 s
= fd_to_stream (STDERR_FILENO
);
1345 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1346 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1347 is big enough to completely fill a 80x25 terminal, so it shuld be
1348 OK. We use a direct write() because it is simpler and least likely
1349 to be clobbered by memory corruption. Writing an error message
1350 longer than that is an error. */
1352 #define ST_VPRINTF_SIZE 2048
1355 st_vprintf (const char *format
, va_list ap
)
1357 static char buffer
[ST_VPRINTF_SIZE
];
1361 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1362 #ifdef HAVE_VSNPRINTF
1363 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1365 written
= vsprintf(buffer
, format
, ap
);
1367 if (written
>= ST_VPRINTF_SIZE
-1)
1369 /* The error message was longer than our buffer. Ouch. Because
1370 we may have messed up things badly, report the error and
1372 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1373 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1374 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1376 #undef ERROR_MESSAGE
1381 written
= write (fd
, buffer
, written
);
1385 /* st_printf()-- printf() function for error output. This just calls
1386 st_vprintf() to do the actual work. */
1389 st_printf (const char *format
, ...)
1393 va_start (ap
, format
);
1394 written
= st_vprintf(format
, ap
);
1400 /* compare_file_filename()-- Given an open stream and a fortran string
1401 * that is a filename, figure out if the file is the same as the
1405 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1407 char path
[PATH_MAX
+ 1];
1409 #ifdef HAVE_WORKING_STAT
1417 if (unpack_filename (path
, name
, len
))
1418 return 0; /* Can't be the same */
1420 /* If the filename doesn't exist, then there is no match with the
1423 if (stat (path
, &st
) < 0)
1426 #ifdef HAVE_WORKING_STAT
1427 s
= (unix_stream
*) (u
->s
);
1428 return (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1432 /* We try to match files by a unique ID. On some filesystems (network
1433 fs and FAT), we can't generate this unique ID, and will simply compare
1435 id1
= id_from_path (path
);
1436 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1438 return (id1
== id2
);
1441 if (len
!= u
->file_len
)
1443 return (memcmp(path
, u
->file
, len
) == 0);
1448 #ifdef HAVE_WORKING_STAT
1449 # define FIND_FILE0_DECL gfstat_t *st
1450 # define FIND_FILE0_ARGS st
1452 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1453 # define FIND_FILE0_ARGS id, file, file_len
1456 /* find_file0()-- Recursive work function for find_file() */
1459 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1462 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1469 #ifdef HAVE_WORKING_STAT
1472 unix_stream
*s
= (unix_stream
*) (u
->s
);
1473 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1478 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1485 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1489 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1493 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1501 /* find_file()-- Take the current filename and see if there is a unit
1502 * that has the file already open. Returns a pointer to the unit if so. */
1505 find_file (const char *file
, gfc_charlen_type file_len
)
1507 char path
[PATH_MAX
+ 1];
1510 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1514 if (unpack_filename (path
, file
, file_len
))
1517 if (stat (path
, &st
[0]) < 0)
1520 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1521 id
= id_from_path (path
);
1524 __gthread_mutex_lock (&unit_lock
);
1526 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1530 if (! __gthread_mutex_trylock (&u
->lock
))
1532 /* assert (u->closed == 0); */
1533 __gthread_mutex_unlock (&unit_lock
);
1537 inc_waiting_locked (u
);
1539 __gthread_mutex_unlock (&unit_lock
);
1542 __gthread_mutex_lock (&u
->lock
);
1545 __gthread_mutex_lock (&unit_lock
);
1546 __gthread_mutex_unlock (&u
->lock
);
1547 if (predec_waiting_locked (u
) == 0)
1552 dec_waiting_unlocked (u
);
1558 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1562 if (u
->unit_number
> min_unit
)
1564 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1568 if (u
->unit_number
>= min_unit
)
1570 if (__gthread_mutex_trylock (&u
->lock
))
1574 __gthread_mutex_unlock (&u
->lock
);
1582 flush_all_units (void)
1587 __gthread_mutex_lock (&unit_lock
);
1590 u
= flush_all_units_1 (unit_root
, min_unit
);
1592 inc_waiting_locked (u
);
1593 __gthread_mutex_unlock (&unit_lock
);
1597 __gthread_mutex_lock (&u
->lock
);
1599 min_unit
= u
->unit_number
+ 1;
1604 __gthread_mutex_lock (&unit_lock
);
1605 __gthread_mutex_unlock (&u
->lock
);
1606 (void) predec_waiting_locked (u
);
1610 __gthread_mutex_lock (&unit_lock
);
1611 __gthread_mutex_unlock (&u
->lock
);
1612 if (predec_waiting_locked (u
) == 0)
1620 /* delete_file()-- Given a unit structure, delete the file associated
1621 * with the unit. Returns nonzero if something went wrong. */
1624 delete_file (gfc_unit
* u
)
1626 char path
[PATH_MAX
+ 1];
1628 if (unpack_filename (path
, u
->file
, u
->file_len
))
1629 { /* Shouldn't be possible */
1634 return unlink (path
);
1638 /* file_exists()-- Returns nonzero if the current filename exists on
1642 file_exists (const char *file
, gfc_charlen_type file_len
)
1644 char path
[PATH_MAX
+ 1];
1646 if (unpack_filename (path
, file
, file_len
))
1649 return !(access (path
, F_OK
));
1653 /* file_size()-- Returns the size of the file. */
1656 file_size (const char *file
, gfc_charlen_type file_len
)
1658 char path
[PATH_MAX
+ 1];
1661 if (unpack_filename (path
, file
, file_len
))
1664 if (stat (path
, &statbuf
) < 0)
1667 return (GFC_IO_INT
) statbuf
.st_size
;
1670 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1672 /* inquire_sequential()-- Given a fortran string, determine if the
1673 * file is suitable for sequential access. Returns a C-style
1677 inquire_sequential (const char *string
, int len
)
1679 char path
[PATH_MAX
+ 1];
1682 if (string
== NULL
||
1683 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1686 if (S_ISREG (statbuf
.st_mode
) ||
1687 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1690 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1697 /* inquire_direct()-- Given a fortran string, determine if the file is
1698 * suitable for direct access. Returns a C-style string. */
1701 inquire_direct (const char *string
, int len
)
1703 char path
[PATH_MAX
+ 1];
1706 if (string
== NULL
||
1707 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1710 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1713 if (S_ISDIR (statbuf
.st_mode
) ||
1714 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1721 /* inquire_formatted()-- Given a fortran string, determine if the file
1722 * is suitable for formatted form. Returns a C-style string. */
1725 inquire_formatted (const char *string
, int len
)
1727 char path
[PATH_MAX
+ 1];
1730 if (string
== NULL
||
1731 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1734 if (S_ISREG (statbuf
.st_mode
) ||
1735 S_ISBLK (statbuf
.st_mode
) ||
1736 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1739 if (S_ISDIR (statbuf
.st_mode
))
1746 /* inquire_unformatted()-- Given a fortran string, determine if the file
1747 * is suitable for unformatted form. Returns a C-style string. */
1750 inquire_unformatted (const char *string
, int len
)
1752 return inquire_formatted (string
, len
);
1756 /* inquire_access()-- Given a fortran string, determine if the file is
1757 * suitable for access. */
1760 inquire_access (const char *string
, int len
, int mode
)
1762 char path
[PATH_MAX
+ 1];
1764 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1765 access (path
, mode
) < 0)
1772 /* inquire_read()-- Given a fortran string, determine if the file is
1773 * suitable for READ access. */
1776 inquire_read (const char *string
, int len
)
1778 return inquire_access (string
, len
, R_OK
);
1782 /* inquire_write()-- Given a fortran string, determine if the file is
1783 * suitable for READ access. */
1786 inquire_write (const char *string
, int len
)
1788 return inquire_access (string
, len
, W_OK
);
1792 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1793 * suitable for read and write access. */
1796 inquire_readwrite (const char *string
, int len
)
1798 return inquire_access (string
, len
, R_OK
| W_OK
);
1802 /* file_length()-- Return the file length in bytes, -1 if unknown */
1805 file_length (stream
* s
)
1807 gfc_offset curr
, end
;
1808 if (!is_seekable (s
))
1813 end
= sseek (s
, 0, SEEK_END
);
1814 sseek (s
, curr
, SEEK_SET
);
1819 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1823 is_seekable (stream
*s
)
1825 /* By convention, if file_length == -1, the file is not
1827 return ((unix_stream
*) s
)->file_length
!=-1;
1831 /* is_special()-- Return nonzero if the stream is not a regular file. */
1834 is_special (stream
*s
)
1836 return ((unix_stream
*) s
)->special_file
;
1841 stream_isatty (stream
*s
)
1843 return isatty (((unix_stream
*) s
)->fd
);
1847 stream_ttyname (stream
*s
__attribute__ ((unused
)),
1848 char * buf
__attribute__ ((unused
)),
1849 size_t buflen
__attribute__ ((unused
)))
1851 #ifdef HAVE_TTYNAME_R
1852 return ttyname_r (((unix_stream
*) s
)->fd
, buf
, buflen
);
1853 #elif defined HAVE_TTYNAME
1856 p
= ttyname (((unix_stream
*) s
)->fd
);
1862 memcpy (buf
, p
, plen
);
1872 /* How files are stored: This is an operating-system specific issue,
1873 and therefore belongs here. There are three cases to consider.
1876 Records are written as block of bytes corresponding to the record
1877 length of the file. This goes for both formatted and unformatted
1878 records. Positioning is done explicitly for each data transfer,
1879 so positioning is not much of an issue.
1881 Sequential Formatted:
1882 Records are separated by newline characters. The newline character
1883 is prohibited from appearing in a string. If it does, this will be
1884 messed up on the next read. End of file is also the end of a record.
1886 Sequential Unformatted:
1887 In this case, we are merely copying bytes to and from main storage,
1888 yet we need to keep track of varying record lengths. We adopt
1889 the solution used by f2c. Each record contains a pair of length
1892 Length of record n in bytes
1894 Length of record n in bytes
1896 Length of record n+1 in bytes
1898 Length of record n+1 in bytes
1900 The length is stored at the end of a record to allow backspacing to the
1901 previous record. Between data transfer statements, the file pointer
1902 is left pointing to the first length of the current record.
1904 ENDFILE records are never explicitly stored.