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 /********************************************************************
260 Raw I/O functions (read, write, seek, tell, truncate, close).
262 These functions wrap the basic POSIX I/O syscalls. Any deviation in
263 semantics is a bug, except the following: write restarts in case
264 of being interrupted by a signal, and as the first argument the
265 functions take the unix_stream struct rather than an integer file
266 descriptor. Also, for POSIX read() and write() a nbyte argument larger
267 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
268 than size_t as for POSIX read/write.
269 *********************************************************************/
272 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
278 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
280 /* For read we can't do I/O in a loop like raw_write does, because
281 that will break applications that wait for interactive I/O. */
282 return read (s
->fd
, buf
, nbyte
);
286 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
288 ssize_t trans
, bytes_left
;
292 buf_st
= (char *) buf
;
294 /* We must write in a loop since some systems don't restart system
295 calls in case of a signal. */
296 while (bytes_left
> 0)
298 trans
= write (s
->fd
, buf_st
, bytes_left
);
310 return nbyte
- bytes_left
;
314 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
316 return lseek (s
->fd
, offset
, whence
);
320 raw_tell (unix_stream
* s
)
322 return lseek (s
->fd
, 0, SEEK_CUR
);
326 raw_truncate (unix_stream
* s
, gfc_offset length
)
337 h
= (HANDLE
) _get_osfhandle (s
->fd
);
338 if (h
== INVALID_HANDLE_VALUE
)
343 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
346 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
348 if (!SetEndOfFile (h
))
353 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
357 lseek (s
->fd
, cur
, SEEK_SET
);
359 #elif defined HAVE_FTRUNCATE
360 return ftruncate (s
->fd
, length
);
361 #elif defined HAVE_CHSIZE
362 return chsize (s
->fd
, length
);
364 runtime_error ("required ftruncate or chsize support not present");
370 raw_close (unix_stream
* s
)
374 if (s
->fd
!= STDOUT_FILENO
375 && s
->fd
!= STDERR_FILENO
376 && s
->fd
!= STDIN_FILENO
)
377 retval
= close (s
->fd
);
385 raw_init (unix_stream
* s
)
387 s
->st
.read
= (void *) raw_read
;
388 s
->st
.write
= (void *) raw_write
;
389 s
->st
.seek
= (void *) raw_seek
;
390 s
->st
.tell
= (void *) raw_tell
;
391 s
->st
.trunc
= (void *) raw_truncate
;
392 s
->st
.close
= (void *) raw_close
;
393 s
->st
.flush
= (void *) raw_flush
;
400 /*********************************************************************
401 Buffered I/O functions. These functions have the same semantics as the
402 raw I/O functions above, except that they are buffered in order to
403 improve performance. The buffer must be flushed when switching from
404 reading to writing and vice versa.
405 *********************************************************************/
408 buf_flush (unix_stream
* s
)
412 /* Flushing in read mode means discarding read bytes. */
418 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
419 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
422 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
424 s
->physical_offset
= s
->buffer_offset
+ writelen
;
426 /* Don't increment file_length if the file is non-seekable. */
427 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
428 s
->file_length
= s
->physical_offset
;
430 s
->ndirty
-= writelen
;
442 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
445 s
->buffer_offset
= s
->logical_offset
;
447 /* Is the data we want in the buffer? */
448 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
449 && s
->buffer_offset
<= s
->logical_offset
)
450 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
453 /* First copy the active bytes if applicable, then read the rest
454 either directly or filling the buffer. */
457 ssize_t to_read
, did_read
;
458 gfc_offset new_logical
;
461 if (s
->logical_offset
>= s
->buffer_offset
462 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
464 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
465 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
469 /* At this point we consider all bytes in the buffer discarded. */
470 to_read
= nbyte
- nread
;
471 new_logical
= s
->logical_offset
+ nread
;
472 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
473 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
475 s
->buffer_offset
= s
->physical_offset
= new_logical
;
476 if (to_read
<= BUFFER_SIZE
/2)
478 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
479 s
->physical_offset
+= did_read
;
480 s
->active
= did_read
;
481 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
482 memcpy (p
, s
->buffer
, did_read
);
486 did_read
= raw_read (s
, p
, to_read
);
487 s
->physical_offset
+= did_read
;
490 nbyte
= did_read
+ nread
;
492 s
->logical_offset
+= nbyte
;
497 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
500 s
->buffer_offset
= s
->logical_offset
;
502 /* Does the data fit into the buffer? As a special case, if the
503 buffer is empty and the request is bigger than BUFFER_SIZE/2,
504 write directly. This avoids the case where the buffer would have
505 to be flushed at every write. */
506 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
507 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
508 && s
->buffer_offset
<= s
->logical_offset
509 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
511 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
512 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
518 /* Flush, and either fill the buffer with the new data, or if
519 the request is bigger than the buffer size, write directly
520 bypassing the buffer. */
522 if (nbyte
<= BUFFER_SIZE
/2)
524 memcpy (s
->buffer
, buf
, nbyte
);
525 s
->buffer_offset
= s
->logical_offset
;
530 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
)
532 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
534 s
->physical_offset
= s
->logical_offset
;
537 nbyte
= raw_write (s
, buf
, nbyte
);
538 s
->physical_offset
+= nbyte
;
541 s
->logical_offset
+= nbyte
;
542 /* Don't increment file_length if the file is non-seekable. */
543 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
544 s
->file_length
= s
->logical_offset
;
549 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
556 offset
+= s
->logical_offset
;
559 offset
+= s
->file_length
;
569 s
->logical_offset
= offset
;
574 buf_tell (unix_stream
* s
)
576 return s
->logical_offset
;
580 buf_truncate (unix_stream
* s
, gfc_offset length
)
584 if (buf_flush (s
) != 0)
586 r
= raw_truncate (s
, length
);
588 s
->file_length
= length
;
593 buf_close (unix_stream
* s
)
595 if (buf_flush (s
) != 0)
598 return raw_close (s
);
602 buf_init (unix_stream
* s
)
604 s
->st
.read
= (void *) buf_read
;
605 s
->st
.write
= (void *) buf_write
;
606 s
->st
.seek
= (void *) buf_seek
;
607 s
->st
.tell
= (void *) buf_tell
;
608 s
->st
.trunc
= (void *) buf_truncate
;
609 s
->st
.close
= (void *) buf_close
;
610 s
->st
.flush
= (void *) buf_flush
;
612 s
->buffer
= get_mem (BUFFER_SIZE
);
617 /*********************************************************************
618 memory stream functions - These are used for internal files
620 The idea here is that a single stream structure is created and all
621 requests must be satisfied from it. The location and size of the
622 buffer is the character variable supplied to the READ or WRITE
625 *********************************************************************/
628 mem_alloc_r (stream
* strm
, int * len
)
630 unix_stream
* s
= (unix_stream
*) strm
;
632 gfc_offset where
= s
->logical_offset
;
634 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
637 n
= s
->buffer_offset
+ s
->active
- where
;
641 s
->logical_offset
= where
+ *len
;
643 return s
->buffer
+ (where
- s
->buffer_offset
);
648 mem_alloc_r4 (stream
* strm
, int * len
)
650 unix_stream
* s
= (unix_stream
*) strm
;
652 gfc_offset where
= s
->logical_offset
;
654 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
657 n
= s
->buffer_offset
+ s
->active
- where
;
661 s
->logical_offset
= where
+ *len
;
663 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
668 mem_alloc_w (stream
* strm
, int * len
)
670 unix_stream
* s
= (unix_stream
*) strm
;
672 gfc_offset where
= s
->logical_offset
;
676 if (where
< s
->buffer_offset
)
679 if (m
> s
->file_length
)
682 s
->logical_offset
= m
;
684 return s
->buffer
+ (where
- s
->buffer_offset
);
689 mem_alloc_w4 (stream
* strm
, int * len
)
691 unix_stream
* s
= (unix_stream
*) strm
;
693 gfc_offset where
= s
->logical_offset
;
694 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
698 if (where
< s
->buffer_offset
)
701 if (m
> s
->file_length
)
704 s
->logical_offset
= m
;
705 return &result
[where
- s
->buffer_offset
];
709 /* Stream read function for character(kine=1) internal units. */
712 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
717 p
= mem_alloc_r (s
, &nb
);
728 /* Stream read function for chracter(kind=4) internal units. */
731 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
736 p
= mem_alloc_r (s
, &nb
);
747 /* Stream write function for character(kind=1) internal units. */
750 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
755 p
= mem_alloc_w (s
, &nb
);
766 /* Stream write function for character(kind=4) internal units. */
769 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
774 p
= mem_alloc_w4 (s
, &nw
);
778 *p
++ = (gfc_char4_t
) *((char *) buf
);
787 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
789 unix_stream
* s
= (unix_stream
*) strm
;
795 offset
+= s
->logical_offset
;
798 offset
+= s
->file_length
;
804 /* Note that for internal array I/O it's actually possible to have a
805 negative offset, so don't check for that. */
806 if (offset
> s
->file_length
)
812 s
->logical_offset
= offset
;
814 /* Returning < 0 is the error indicator for sseek(), so return 0 if
815 offset is negative. Thus if the return value is 0, the caller
816 has to use stell() to get the real value of logical_offset. */
824 mem_tell (stream
* s
)
826 return ((unix_stream
*)s
)->logical_offset
;
831 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
832 gfc_offset length
__attribute__ ((unused
)))
839 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
846 mem_close (unix_stream
* s
)
855 /*********************************************************************
856 Public functions -- A reimplementation of this module needs to
857 define functional equivalents of the following.
858 *********************************************************************/
860 /* open_internal()-- Returns a stream structure from a character(kind=1)
864 open_internal (char *base
, int length
, gfc_offset offset
)
868 s
= get_mem (sizeof (unix_stream
));
869 memset (s
, '\0', sizeof (unix_stream
));
872 s
->buffer_offset
= offset
;
874 s
->logical_offset
= 0;
875 s
->active
= s
->file_length
= length
;
877 s
->st
.close
= (void *) mem_close
;
878 s
->st
.seek
= (void *) mem_seek
;
879 s
->st
.tell
= (void *) mem_tell
;
880 s
->st
.trunc
= (void *) mem_truncate
;
881 s
->st
.read
= (void *) mem_read
;
882 s
->st
.write
= (void *) mem_write
;
883 s
->st
.flush
= (void *) mem_flush
;
888 /* open_internal4()-- Returns a stream structure from a character(kind=4)
892 open_internal4 (char *base
, int length
, gfc_offset offset
)
896 s
= get_mem (sizeof (unix_stream
));
897 memset (s
, '\0', sizeof (unix_stream
));
900 s
->buffer_offset
= offset
;
902 s
->logical_offset
= 0;
903 s
->active
= s
->file_length
= length
;
905 s
->st
.close
= (void *) mem_close
;
906 s
->st
.seek
= (void *) mem_seek
;
907 s
->st
.tell
= (void *) mem_tell
;
908 s
->st
.trunc
= (void *) mem_truncate
;
909 s
->st
.read
= (void *) mem_read4
;
910 s
->st
.write
= (void *) mem_write4
;
911 s
->st
.flush
= (void *) mem_flush
;
917 /* fd_to_stream()-- Given an open file descriptor, build a stream
921 fd_to_stream (int fd
)
926 s
= get_mem (sizeof (unix_stream
));
927 memset (s
, '\0', sizeof (unix_stream
));
930 s
->buffer_offset
= 0;
931 s
->physical_offset
= 0;
932 s
->logical_offset
= 0;
934 /* Get the current length of the file. */
936 fstat (fd
, &statbuf
);
938 s
->st_dev
= statbuf
.st_dev
;
939 s
->st_ino
= statbuf
.st_ino
;
940 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
942 if (S_ISREG (statbuf
.st_mode
))
943 s
->file_length
= statbuf
.st_size
;
944 else if (S_ISBLK (statbuf
.st_mode
))
946 /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)? */
947 gfc_offset cur
= lseek (fd
, 0, SEEK_CUR
);
948 s
->file_length
= lseek (fd
, 0, SEEK_END
);
949 lseek (fd
, cur
, SEEK_SET
);
954 if (!(S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
955 || options
.all_unbuffered
956 ||(options
.unbuffered_preconnected
&&
957 (s
->fd
== STDIN_FILENO
958 || s
->fd
== STDOUT_FILENO
959 || s
->fd
== STDERR_FILENO
))
969 /* Given the Fortran unit number, convert it to a C file descriptor. */
972 unit_to_fd (int unit
)
977 us
= find_unit (unit
);
981 fd
= ((unix_stream
*) us
->s
)->fd
;
987 /* unpack_filename()-- Given a fortran string and a pointer to a
988 * buffer that is PATH_MAX characters, convert the fortran string to a
989 * C string in the buffer. Returns nonzero if this is not possible. */
992 unpack_filename (char *cstring
, const char *fstring
, int len
)
996 len
= fstrlen (fstring
, len
);
1000 memmove (cstring
, fstring
, len
);
1001 cstring
[len
] = '\0';
1007 /* tempfile()-- Generate a temporary filename for a scratch file and
1008 * open it. mkstemp() opens the file for reading and writing, but the
1009 * library mode prevents anything that is not allowed. The descriptor
1010 * is returned, which is -1 on error. The template is pointed to by
1011 * opp->file, which is copied into the unit structure
1012 * and freed later. */
1015 tempfile (st_parameter_open
*opp
)
1017 const char *tempdir
;
1019 const char *slash
= "/";
1022 tempdir
= getenv ("GFORTRAN_TMPDIR");
1024 if (tempdir
== NULL
)
1026 char buffer
[MAX_PATH
+ 1];
1028 ret
= GetTempPath (MAX_PATH
, buffer
);
1029 /* If we are not able to get a temp-directory, we use
1030 current directory. */
1031 if (ret
> MAX_PATH
|| !ret
)
1035 tempdir
= strdup (buffer
);
1038 if (tempdir
== NULL
)
1039 tempdir
= getenv ("TMP");
1040 if (tempdir
== NULL
)
1041 tempdir
= getenv ("TEMP");
1042 if (tempdir
== NULL
)
1043 tempdir
= DEFAULT_TEMPDIR
;
1045 /* Check for special case that tempdir contains slash
1046 or backslash at end. */
1047 if (*tempdir
== 0 || tempdir
[strlen (tempdir
) - 1] == '/'
1049 || tempdir
[strlen (tempdir
) - 1] == '\\'
1054 template = get_mem (strlen (tempdir
) + 20);
1057 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir
, slash
);
1059 fd
= mkstemp (template);
1061 #else /* HAVE_MKSTEMP */
1065 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir
, slash
);
1066 if (!mktemp (template))
1068 #if defined(HAVE_CRLF) && defined(O_BINARY)
1069 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1070 S_IREAD
| S_IWRITE
);
1072 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1075 while (fd
== -1 && errno
== EEXIST
);
1076 #endif /* HAVE_MKSTEMP */
1078 opp
->file
= template;
1079 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1085 /* regular_file()-- Open a regular file.
1086 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1087 * unless an error occurs.
1088 * Returns the descriptor, which is less than zero on error. */
1091 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1093 char path
[PATH_MAX
+ 1];
1099 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1101 errno
= ENOENT
; /* Fake an OS error */
1106 if (opp
->file_len
== 7)
1108 if (strncmp (path
, "CONOUT$", 7) == 0
1109 || strncmp (path
, "CONERR$", 7) == 0)
1111 fd
= open ("/dev/conout", O_WRONLY
);
1112 flags
->action
= ACTION_WRITE
;
1117 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1119 fd
= open ("/dev/conin", O_RDONLY
);
1120 flags
->action
= ACTION_READ
;
1127 if (opp
->file_len
== 7)
1129 if (strncmp (path
, "CONOUT$", 7) == 0
1130 || strncmp (path
, "CONERR$", 7) == 0)
1132 fd
= open ("CONOUT$", O_WRONLY
);
1133 flags
->action
= ACTION_WRITE
;
1138 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1140 fd
= open ("CONIN$", O_RDONLY
);
1141 flags
->action
= ACTION_READ
;
1148 switch (flags
->action
)
1158 case ACTION_READWRITE
:
1159 case ACTION_UNSPECIFIED
:
1164 internal_error (&opp
->common
, "regular_file(): Bad action");
1167 switch (flags
->status
)
1170 crflag
= O_CREAT
| O_EXCL
;
1173 case STATUS_OLD
: /* open will fail if the file does not exist*/
1177 case STATUS_UNKNOWN
:
1178 case STATUS_SCRATCH
:
1182 case STATUS_REPLACE
:
1183 crflag
= O_CREAT
| O_TRUNC
;
1187 internal_error (&opp
->common
, "regular_file(): Bad status");
1190 /* rwflag |= O_LARGEFILE; */
1192 #if defined(HAVE_CRLF) && defined(O_BINARY)
1196 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1197 fd
= open (path
, rwflag
| crflag
, mode
);
1198 if (flags
->action
!= ACTION_UNSPECIFIED
)
1203 flags
->action
= ACTION_READWRITE
;
1206 if (errno
!= EACCES
&& errno
!= EROFS
)
1209 /* retry for read-only access */
1211 fd
= open (path
, rwflag
| crflag
, mode
);
1214 flags
->action
= ACTION_READ
;
1215 return fd
; /* success */
1218 if (errno
!= EACCES
)
1219 return fd
; /* failure */
1221 /* retry for write-only access */
1223 fd
= open (path
, rwflag
| crflag
, mode
);
1226 flags
->action
= ACTION_WRITE
;
1227 return fd
; /* success */
1229 return fd
; /* failure */
1233 /* open_external()-- Open an external file, unix specific version.
1234 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1235 * Returns NULL on operating system error. */
1238 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1242 if (flags
->status
== STATUS_SCRATCH
)
1244 fd
= tempfile (opp
);
1245 if (flags
->action
== ACTION_UNSPECIFIED
)
1246 flags
->action
= ACTION_READWRITE
;
1248 #if HAVE_UNLINK_OPEN_FILE
1249 /* We can unlink scratch files now and it will go away when closed. */
1256 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1258 fd
= regular_file (opp
, flags
);
1265 return fd_to_stream (fd
);
1269 /* input_stream()-- Return a stream pointer to the default input stream.
1270 * Called on initialization. */
1275 return fd_to_stream (STDIN_FILENO
);
1279 /* output_stream()-- Return a stream pointer to the default output stream.
1280 * Called on initialization. */
1283 output_stream (void)
1287 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1288 setmode (STDOUT_FILENO
, O_BINARY
);
1291 s
= fd_to_stream (STDOUT_FILENO
);
1296 /* error_stream()-- Return a stream pointer to the default error stream.
1297 * Called on initialization. */
1304 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1305 setmode (STDERR_FILENO
, O_BINARY
);
1308 s
= fd_to_stream (STDERR_FILENO
);
1313 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1314 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1315 is big enough to completely fill a 80x25 terminal, so it shuld be
1316 OK. We use a direct write() because it is simpler and least likely
1317 to be clobbered by memory corruption. Writing an error message
1318 longer than that is an error. */
1320 #define ST_VPRINTF_SIZE 2048
1323 st_vprintf (const char *format
, va_list ap
)
1325 static char buffer
[ST_VPRINTF_SIZE
];
1329 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1330 #ifdef HAVE_VSNPRINTF
1331 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1333 written
= vsprintf(buffer
, format
, ap
);
1335 if (written
>= ST_VPRINTF_SIZE
-1)
1337 /* The error message was longer than our buffer. Ouch. Because
1338 we may have messed up things badly, report the error and
1340 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1341 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1342 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1344 #undef ERROR_MESSAGE
1349 written
= write (fd
, buffer
, written
);
1353 /* st_printf()-- printf() function for error output. This just calls
1354 st_vprintf() to do the actual work. */
1357 st_printf (const char *format
, ...)
1361 va_start (ap
, format
);
1362 written
= st_vprintf(format
, ap
);
1368 /* compare_file_filename()-- Given an open stream and a fortran string
1369 * that is a filename, figure out if the file is the same as the
1373 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1375 char path
[PATH_MAX
+ 1];
1377 #ifdef HAVE_WORKING_STAT
1385 if (unpack_filename (path
, name
, len
))
1386 return 0; /* Can't be the same */
1388 /* If the filename doesn't exist, then there is no match with the
1391 if (stat (path
, &st
) < 0)
1394 #ifdef HAVE_WORKING_STAT
1395 s
= (unix_stream
*) (u
->s
);
1396 return (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1400 /* We try to match files by a unique ID. On some filesystems (network
1401 fs and FAT), we can't generate this unique ID, and will simply compare
1403 id1
= id_from_path (path
);
1404 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1406 return (id1
== id2
);
1409 if (len
!= u
->file_len
)
1411 return (memcmp(path
, u
->file
, len
) == 0);
1416 #ifdef HAVE_WORKING_STAT
1417 # define FIND_FILE0_DECL gfstat_t *st
1418 # define FIND_FILE0_ARGS st
1420 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1421 # define FIND_FILE0_ARGS id, file, file_len
1424 /* find_file0()-- Recursive work function for find_file() */
1427 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1430 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1437 #ifdef HAVE_WORKING_STAT
1440 unix_stream
*s
= (unix_stream
*) (u
->s
);
1441 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1446 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1453 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1457 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1461 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1469 /* find_file()-- Take the current filename and see if there is a unit
1470 * that has the file already open. Returns a pointer to the unit if so. */
1473 find_file (const char *file
, gfc_charlen_type file_len
)
1475 char path
[PATH_MAX
+ 1];
1478 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1482 if (unpack_filename (path
, file
, file_len
))
1485 if (stat (path
, &st
[0]) < 0)
1488 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1489 id
= id_from_path (path
);
1492 __gthread_mutex_lock (&unit_lock
);
1494 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1498 if (! __gthread_mutex_trylock (&u
->lock
))
1500 /* assert (u->closed == 0); */
1501 __gthread_mutex_unlock (&unit_lock
);
1505 inc_waiting_locked (u
);
1507 __gthread_mutex_unlock (&unit_lock
);
1510 __gthread_mutex_lock (&u
->lock
);
1513 __gthread_mutex_lock (&unit_lock
);
1514 __gthread_mutex_unlock (&u
->lock
);
1515 if (predec_waiting_locked (u
) == 0)
1520 dec_waiting_unlocked (u
);
1526 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1530 if (u
->unit_number
> min_unit
)
1532 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1536 if (u
->unit_number
>= min_unit
)
1538 if (__gthread_mutex_trylock (&u
->lock
))
1542 __gthread_mutex_unlock (&u
->lock
);
1550 flush_all_units (void)
1555 __gthread_mutex_lock (&unit_lock
);
1558 u
= flush_all_units_1 (unit_root
, min_unit
);
1560 inc_waiting_locked (u
);
1561 __gthread_mutex_unlock (&unit_lock
);
1565 __gthread_mutex_lock (&u
->lock
);
1567 min_unit
= u
->unit_number
+ 1;
1572 __gthread_mutex_lock (&unit_lock
);
1573 __gthread_mutex_unlock (&u
->lock
);
1574 (void) predec_waiting_locked (u
);
1578 __gthread_mutex_lock (&unit_lock
);
1579 __gthread_mutex_unlock (&u
->lock
);
1580 if (predec_waiting_locked (u
) == 0)
1588 /* delete_file()-- Given a unit structure, delete the file associated
1589 * with the unit. Returns nonzero if something went wrong. */
1592 delete_file (gfc_unit
* u
)
1594 char path
[PATH_MAX
+ 1];
1596 if (unpack_filename (path
, u
->file
, u
->file_len
))
1597 { /* Shouldn't be possible */
1602 return unlink (path
);
1606 /* file_exists()-- Returns nonzero if the current filename exists on
1610 file_exists (const char *file
, gfc_charlen_type file_len
)
1612 char path
[PATH_MAX
+ 1];
1614 if (unpack_filename (path
, file
, file_len
))
1617 return !(access (path
, F_OK
));
1621 /* file_size()-- Returns the size of the file. */
1624 file_size (const char *file
, gfc_charlen_type file_len
)
1626 char path
[PATH_MAX
+ 1];
1629 if (unpack_filename (path
, file
, file_len
))
1632 if (stat (path
, &statbuf
) < 0)
1635 return (GFC_IO_INT
) statbuf
.st_size
;
1638 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1640 /* inquire_sequential()-- Given a fortran string, determine if the
1641 * file is suitable for sequential access. Returns a C-style
1645 inquire_sequential (const char *string
, int len
)
1647 char path
[PATH_MAX
+ 1];
1650 if (string
== NULL
||
1651 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1654 if (S_ISREG (statbuf
.st_mode
) ||
1655 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1658 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1665 /* inquire_direct()-- Given a fortran string, determine if the file is
1666 * suitable for direct access. Returns a C-style string. */
1669 inquire_direct (const char *string
, int len
)
1671 char path
[PATH_MAX
+ 1];
1674 if (string
== NULL
||
1675 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1678 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1681 if (S_ISDIR (statbuf
.st_mode
) ||
1682 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1689 /* inquire_formatted()-- Given a fortran string, determine if the file
1690 * is suitable for formatted form. Returns a C-style string. */
1693 inquire_formatted (const char *string
, int len
)
1695 char path
[PATH_MAX
+ 1];
1698 if (string
== NULL
||
1699 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1702 if (S_ISREG (statbuf
.st_mode
) ||
1703 S_ISBLK (statbuf
.st_mode
) ||
1704 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1707 if (S_ISDIR (statbuf
.st_mode
))
1714 /* inquire_unformatted()-- Given a fortran string, determine if the file
1715 * is suitable for unformatted form. Returns a C-style string. */
1718 inquire_unformatted (const char *string
, int len
)
1720 return inquire_formatted (string
, len
);
1724 /* inquire_access()-- Given a fortran string, determine if the file is
1725 * suitable for access. */
1728 inquire_access (const char *string
, int len
, int mode
)
1730 char path
[PATH_MAX
+ 1];
1732 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1733 access (path
, mode
) < 0)
1740 /* inquire_read()-- Given a fortran string, determine if the file is
1741 * suitable for READ access. */
1744 inquire_read (const char *string
, int len
)
1746 return inquire_access (string
, len
, R_OK
);
1750 /* inquire_write()-- Given a fortran string, determine if the file is
1751 * suitable for READ access. */
1754 inquire_write (const char *string
, int len
)
1756 return inquire_access (string
, len
, W_OK
);
1760 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1761 * suitable for read and write access. */
1764 inquire_readwrite (const char *string
, int len
)
1766 return inquire_access (string
, len
, R_OK
| W_OK
);
1770 /* file_length()-- Return the file length in bytes, -1 if unknown */
1773 file_length (stream
* s
)
1775 gfc_offset curr
, end
;
1776 if (!is_seekable (s
))
1781 end
= sseek (s
, 0, SEEK_END
);
1782 sseek (s
, curr
, SEEK_SET
);
1787 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1791 is_seekable (stream
*s
)
1793 /* By convention, if file_length == -1, the file is not
1795 return ((unix_stream
*) s
)->file_length
!=-1;
1799 /* is_special()-- Return nonzero if the stream is not a regular file. */
1802 is_special (stream
*s
)
1804 return ((unix_stream
*) s
)->special_file
;
1809 stream_isatty (stream
*s
)
1811 return isatty (((unix_stream
*) s
)->fd
);
1815 stream_ttyname (stream
*s
__attribute__ ((unused
)),
1816 char * buf
__attribute__ ((unused
)),
1817 size_t buflen
__attribute__ ((unused
)))
1819 #ifdef HAVE_TTYNAME_R
1820 return ttyname_r (((unix_stream
*) s
)->fd
, buf
, buflen
);
1821 #elif defined HAVE_TTYNAME
1824 p
= ttyname (((unix_stream
*) s
)->fd
);
1830 memcpy (buf
, p
, plen
);
1840 /* How files are stored: This is an operating-system specific issue,
1841 and therefore belongs here. There are three cases to consider.
1844 Records are written as block of bytes corresponding to the record
1845 length of the file. This goes for both formatted and unformatted
1846 records. Positioning is done explicitly for each data transfer,
1847 so positioning is not much of an issue.
1849 Sequential Formatted:
1850 Records are separated by newline characters. The newline character
1851 is prohibited from appearing in a string. If it does, this will be
1852 messed up on the next read. End of file is also the end of a record.
1854 Sequential Unformatted:
1855 In this case, we are merely copying bytes to and from main storage,
1856 yet we need to keep track of varying record lengths. We adopt
1857 the solution used by f2c. Each record contains a pair of length
1860 Length of record n in bytes
1862 Length of record n in bytes
1864 Length of record n+1 in bytes
1866 Length of record n+1 in bytes
1868 The length is stored at the end of a record to allow backspacing to the
1869 previous record. Between data transfer statements, the file pointer
1870 is left pointing to the first length of the current record.
1872 ENDFILE records are never explicitly stored.