1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
32 /* Unix stream I/O module */
47 /* For mingw, we don't identify files by their inode number, but by a
48 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
49 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
51 #define WIN32_LEAN_AND_MEAN
55 id_from_handle (HANDLE hFile
)
57 BY_HANDLE_FILE_INFORMATION FileInformation
;
59 if (hFile
== INVALID_HANDLE_VALUE
)
62 memset (&FileInformation
, 0, sizeof(FileInformation
));
63 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
66 return ((uint64_t) FileInformation
.nFileIndexLow
)
67 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
72 id_from_path (const char *path
)
77 if (!path
|| !*path
|| access (path
, F_OK
))
80 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
81 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
83 res
= id_from_handle (hFile
);
90 id_from_fd (const int fd
)
92 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
98 #define SSIZE_MAX SHRT_MAX
102 #define PATH_MAX 1024
113 /* These flags aren't defined on all targets (mingw32), so provide them
132 /* Unix stream I/O module */
134 #define BUFFER_SIZE 8192
141 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
142 gfc_offset physical_offset
; /* Current physical file offset */
143 gfc_offset logical_offset
; /* Current logical file offset */
144 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
145 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
147 int len
; /* Physical length of the current buffer */
148 int active
; /* Length of valid bytes in the buffer */
151 int ndirty
; /* Dirty bytes starting at dirty_offset */
153 int special_file
; /* =1 if the fd refers to a special file */
155 io_mode method
; /* Method of stream I/O being used */
158 char small_buffer
[BUFFER_SIZE
];
163 /* Stream structure for internal files. Fields must be kept in sync
164 with unix_stream above, except for the buffer. For internal files
165 we point the buffer pointer directly at the destination memory. */
172 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
173 gfc_offset physical_offset
; /* Current physical file offset */
174 gfc_offset logical_offset
; /* Current logical file offset */
175 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
176 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
178 int len
; /* Physical length of the current buffer */
179 int active
; /* Length of valid bytes in the buffer */
182 int ndirty
; /* Dirty bytes starting at dirty_offset */
184 int special_file
; /* =1 if the fd refers to a special file */
186 io_mode method
; /* Method of stream I/O being used */
192 /* This implementation of stream I/O is based on the paper:
194 * "Exploiting the advantages of mapped files for stream I/O",
195 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
196 * USENIX conference", p. 27-42.
198 * It differs in a number of ways from the version described in the
199 * paper. First of all, threads are not an issue during I/O and we
200 * also don't have to worry about having multiple regions, since
201 * fortran's I/O model only allows you to be one place at a time.
203 * On the other hand, we have to be able to writing at the end of a
204 * stream, read from the start of a stream or read and write blocks of
205 * bytes from an arbitrary position. After opening a file, a pointer
206 * to a stream structure is returned, which is used to handle file
207 * accesses until the file is closed.
209 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
210 * pointer to a block of memory that mirror the file at position
211 * 'where' that is 'len' bytes long. The len integer is updated to
212 * reflect how many bytes were actually read. The only reason for a
213 * short read is end of file. The file pointer is updated. The
214 * pointer is valid until the next call to salloc_*.
216 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
217 * a pointer to a block of memory that is updated to reflect the state
218 * of the file. The length of the buffer is always equal to that
219 * requested. The buffer must be completely set by the caller. When
220 * data has been written, the sfree() function must be called to
221 * indicate that the caller is done writing data to the buffer. This
222 * may or may not cause a physical write.
224 * Short forms of these are salloc_r() and salloc_w() which drop the
225 * 'where' parameter and use the current file pointer. */
228 /*move_pos_offset()-- Move the record pointer right or left
229 *relative to current position */
232 move_pos_offset (stream
* st
, int pos_off
)
234 unix_stream
* str
= (unix_stream
*)st
;
237 str
->logical_offset
+= pos_off
;
239 if (str
->dirty_offset
+ str
->ndirty
> str
->logical_offset
)
241 if (str
->ndirty
+ pos_off
> 0)
242 str
->ndirty
+= pos_off
;
245 str
->dirty_offset
+= pos_off
+ pos_off
;
256 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
257 * standard descriptors, returning a non-standard descriptor. If the
258 * user specifies that system errors should go to standard output,
259 * then closes standard output, we don't want the system errors to a
260 * file that has been given file descriptor 1 or 0. We want to send
261 * the error to the invalid descriptor. */
267 int input
, output
, error
;
269 input
= output
= error
= 0;
271 /* Unix allocates the lowest descriptors first, so a loop is not
272 required, but this order is. */
273 if (fd
== STDIN_FILENO
)
278 if (fd
== STDOUT_FILENO
)
283 if (fd
== STDERR_FILENO
)
290 close (STDIN_FILENO
);
292 close (STDOUT_FILENO
);
294 close (STDERR_FILENO
);
301 is_preconnected (stream
* s
)
305 fd
= ((unix_stream
*) s
)->fd
;
306 if (fd
== STDIN_FILENO
|| fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
)
312 /* If the stream corresponds to a preconnected unit, we flush the
313 corresponding C stream. This is bugware for mixed C-Fortran codes
314 where the C code doesn't flush I/O before returning. */
316 flush_if_preconnected (stream
* s
)
320 fd
= ((unix_stream
*) s
)->fd
;
321 if (fd
== STDIN_FILENO
)
323 else if (fd
== STDOUT_FILENO
)
325 else if (fd
== STDERR_FILENO
)
330 /* Reset a stream after reading/writing. Assumes that the buffers have
334 reset_stream (unix_stream
* s
, size_t bytes_rw
)
336 s
->physical_offset
+= bytes_rw
;
337 s
->logical_offset
= s
->physical_offset
;
338 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
339 s
->file_length
= s
->physical_offset
;
343 /* Read bytes into a buffer, allowing for short reads. If the nbytes
344 * argument is less on return than on entry, it is because we've hit
345 * the end of file. */
348 do_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
356 bytes_left
= *nbytes
;
357 buf_st
= (char *) buf
;
359 /* We must read in a loop since some systems don't restart system
360 calls in case of a signal. */
361 while (bytes_left
> 0)
363 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
364 so we must read in chunks smaller than SSIZE_MAX. */
365 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
366 trans
= read (s
->fd
, buf_st
, trans
);
377 else if (trans
== 0) /* We hit EOF. */
383 *nbytes
-= bytes_left
;
388 /* Write a buffer to a stream, allowing for short writes. */
391 do_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
399 bytes_left
= *nbytes
;
400 buf_st
= (char *) buf
;
402 /* We must write in a loop since some systems don't restart system
403 calls in case of a signal. */
404 while (bytes_left
> 0)
406 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
407 so we must write in chunks smaller than SSIZE_MAX. */
408 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
409 trans
= write (s
->fd
, buf_st
, trans
);
424 *nbytes
-= bytes_left
;
429 /* get_oserror()-- Get the most recent operating system error. For
430 * unix, this is errno. */
435 return strerror (errno
);
439 /*********************************************************************
440 File descriptor stream functions
441 *********************************************************************/
444 /* fd_flush()-- Write bytes that need to be written */
447 fd_flush (unix_stream
* s
)
454 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->dirty_offset
&&
455 lseek (s
->fd
, s
->dirty_offset
, SEEK_SET
) < 0)
458 writelen
= s
->ndirty
;
459 if (do_write (s
, s
->buffer
+ (s
->dirty_offset
- s
->buffer_offset
),
463 s
->physical_offset
= s
->dirty_offset
+ writelen
;
465 /* don't increment file_length if the file is non-seekable */
466 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
467 s
->file_length
= s
->physical_offset
;
469 s
->ndirty
-= writelen
;
477 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
478 * satisfied. This subroutine gets the buffer ready for whatever is
482 fd_alloc (unix_stream
* s
, gfc_offset where
,
483 int *len
__attribute__ ((unused
)))
488 if (*len
<= BUFFER_SIZE
)
490 new_buffer
= s
->small_buffer
;
491 read_len
= BUFFER_SIZE
;
495 new_buffer
= get_mem (*len
);
499 /* Salvage bytes currently within the buffer. This is important for
500 * devices that cannot seek. */
502 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
503 where
<= s
->buffer_offset
+ s
->active
)
506 n
= s
->active
- (where
- s
->buffer_offset
);
507 memmove (new_buffer
, s
->buffer
+ (where
- s
->buffer_offset
), n
);
512 { /* new buffer starts off empty */
516 s
->buffer_offset
= where
;
518 /* free the old buffer if necessary */
520 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
521 free_mem (s
->buffer
);
523 s
->buffer
= new_buffer
;
528 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
529 * we've already buffered the data or we need to load it. Returns
530 * NULL on I/O error. */
533 fd_alloc_r_at (unix_stream
* s
, int *len
)
536 gfc_offset where
= s
->logical_offset
;
538 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
539 where
+ *len
<= s
->buffer_offset
+ s
->active
)
542 /* Return a position within the current buffer */
544 s
->logical_offset
= where
+ *len
;
545 return s
->buffer
+ where
- s
->buffer_offset
;
548 fd_alloc (s
, where
, len
);
550 m
= where
+ s
->active
;
552 if (s
->physical_offset
!= m
&& lseek (s
->fd
, m
, SEEK_SET
) < 0)
555 /* do_read() hangs on read from terminals for *BSD-systems. Only
556 use read() in that case. */
562 n
= read (s
->fd
, s
->buffer
+ s
->active
, s
->len
- s
->active
);
566 s
->physical_offset
= m
+ n
;
573 n
= s
->len
- s
->active
;
574 if (do_read (s
, s
->buffer
+ s
->active
, &n
) != 0)
577 s
->physical_offset
= m
+ n
;
581 if (s
->active
< *len
)
582 *len
= s
->active
; /* Bytes actually available */
584 s
->logical_offset
= where
+ *len
;
590 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
591 * we've already buffered the data or we need to load it. */
594 fd_alloc_w_at (unix_stream
* s
, int *len
)
597 gfc_offset where
= s
->logical_offset
;
599 if (s
->buffer
== NULL
|| s
->buffer_offset
> where
||
600 where
+ *len
> s
->buffer_offset
+ s
->len
)
603 if (fd_flush (s
) == FAILURE
)
605 fd_alloc (s
, where
, len
);
608 /* Return a position within the current buffer */
610 || where
> s
->dirty_offset
+ s
->ndirty
611 || s
->dirty_offset
> where
+ *len
)
612 { /* Discontiguous blocks, start with a clean buffer. */
613 /* Flush the buffer. */
616 s
->dirty_offset
= where
;
621 gfc_offset start
; /* Merge with the existing data. */
622 if (where
< s
->dirty_offset
)
625 start
= s
->dirty_offset
;
626 if (where
+ *len
> s
->dirty_offset
+ s
->ndirty
)
627 s
->ndirty
= where
+ *len
- start
;
629 s
->ndirty
= s
->dirty_offset
+ s
->ndirty
- start
;
630 s
->dirty_offset
= start
;
633 s
->logical_offset
= where
+ *len
;
635 /* Don't increment file_length if the file is non-seekable. */
637 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
638 s
->file_length
= s
->logical_offset
;
640 n
= s
->logical_offset
- s
->buffer_offset
;
644 return s
->buffer
+ where
- s
->buffer_offset
;
649 fd_sfree (unix_stream
* s
)
651 if (s
->ndirty
!= 0 &&
652 (s
->buffer
!= s
->small_buffer
|| options
.all_unbuffered
||
653 s
->method
== SYNC_UNBUFFERED
))
661 fd_seek (unix_stream
* s
, gfc_offset offset
)
664 if (s
->file_length
== -1)
667 if (s
->physical_offset
== offset
) /* Are we lucky and avoid syscall? */
669 s
->logical_offset
= offset
;
673 if (lseek (s
->fd
, offset
, SEEK_SET
) >= 0)
675 s
->physical_offset
= s
->logical_offset
= offset
;
684 /* truncate_file()-- Given a unit, truncate the file at the current
685 * position. Sets the physical location to the new end of the file.
686 * Returns nonzero on error. */
689 fd_truncate (unix_stream
* s
)
691 /* Non-seekable files, like terminals and fifo's fail the lseek so just
692 return success, there is nothing to truncate. If its not a pipe there
693 is a real problem. */
694 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) == -1)
702 /* Using ftruncate on a seekable special file (like /dev/null)
703 is undefined, so we treat it as if the ftruncate succeeded. */
706 #ifdef HAVE_FTRUNCATE
707 ftruncate (s
->fd
, s
->logical_offset
) != 0
708 #elif defined HAVE_CHSIZE
709 chsize (s
->fd
, s
->logical_offset
) != 0
711 /* If we have neither, always fail and exit, noisily. */
712 runtime_error ("required ftruncate or chsize support not present"), 1
716 /* The truncation failed and we need to handle this gracefully.
717 The file length remains the same, but the file-descriptor
718 offset needs adjustment per the successful lseek above.
719 (Similarly, the contents of the buffer isn't valid anymore.)
720 A ftruncate call does not affect the physical (file-descriptor)
721 offset, according to the ftruncate manual, so neither should a
723 s
->physical_offset
= s
->logical_offset
;
728 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
734 /* Similar to memset(), but operating on a stream instead of a string.
735 Takes care of not using too much memory. */
738 fd_sset (unix_stream
* s
, int c
, size_t n
)
746 while (bytes_left
> 0)
748 /* memset() in chunks of BUFFER_SIZE. */
749 trans
= (bytes_left
< BUFFER_SIZE
) ? bytes_left
: BUFFER_SIZE
;
751 p
= fd_alloc_w_at (s
, &trans
);
753 memset (p
, c
, trans
);
764 /* Stream read function. Avoids using a buffer for big reads. The
765 interface is like POSIX read(), but the nbytes argument is a
766 pointer; on return it contains the number of bytes written. The
767 function return value is the status indicator (0 for success). */
770 fd_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
775 if (*nbytes
< BUFFER_SIZE
&& s
->method
== SYNC_BUFFERED
)
778 p
= fd_alloc_r_at (s
, &tmp
);
782 memcpy (buf
, p
, *nbytes
);
792 /* If the request is bigger than BUFFER_SIZE we flush the buffers
793 and read directly. */
794 if (fd_flush (s
) == FAILURE
)
800 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
806 status
= do_read (s
, buf
, nbytes
);
807 reset_stream (s
, *nbytes
);
812 /* Stream write function. Avoids using a buffer for big writes. The
813 interface is like POSIX write(), but the nbytes argument is a
814 pointer; on return it contains the number of bytes written. The
815 function return value is the status indicator (0 for success). */
818 fd_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
823 if (*nbytes
< BUFFER_SIZE
&& s
->method
== SYNC_BUFFERED
)
826 p
= fd_alloc_w_at (s
, &tmp
);
830 memcpy (p
, buf
, *nbytes
);
840 /* If the request is bigger than BUFFER_SIZE we flush the buffers
841 and write directly. */
842 if (fd_flush (s
) == FAILURE
)
848 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
854 status
= do_write (s
, buf
, nbytes
);
855 reset_stream (s
, *nbytes
);
861 fd_close (unix_stream
* s
)
863 if (fd_flush (s
) == FAILURE
)
866 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
867 free_mem (s
->buffer
);
869 if (s
->fd
!= STDOUT_FILENO
&& s
->fd
!= STDERR_FILENO
&& s
->fd
!= STDIN_FILENO
)
871 if (close (s
->fd
) < 0)
882 fd_open (unix_stream
* s
)
885 s
->method
= SYNC_UNBUFFERED
;
887 s
->method
= SYNC_BUFFERED
;
889 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
890 s
->st
.sfree
= (void *) fd_sfree
;
891 s
->st
.close
= (void *) fd_close
;
892 s
->st
.seek
= (void *) fd_seek
;
893 s
->st
.trunc
= (void *) fd_truncate
;
894 s
->st
.read
= (void *) fd_read
;
895 s
->st
.write
= (void *) fd_write
;
896 s
->st
.set
= (void *) fd_sset
;
904 /*********************************************************************
905 memory stream functions - These are used for internal files
907 The idea here is that a single stream structure is created and all
908 requests must be satisfied from it. The location and size of the
909 buffer is the character variable supplied to the READ or WRITE
912 *********************************************************************/
916 mem_alloc_r_at (int_stream
* s
, int *len
)
919 gfc_offset where
= s
->logical_offset
;
921 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
924 s
->logical_offset
= where
+ *len
;
926 n
= s
->buffer_offset
+ s
->active
- where
;
930 return s
->buffer
+ (where
- s
->buffer_offset
);
935 mem_alloc_w_at (int_stream
* s
, int *len
)
938 gfc_offset where
= s
->logical_offset
;
940 assert (*len
>= 0); /* Negative values not allowed. */
944 if (where
< s
->buffer_offset
)
947 if (m
> s
->file_length
)
950 s
->logical_offset
= m
;
952 return s
->buffer
+ (where
- s
->buffer_offset
);
956 /* Stream read function for internal units. */
959 mem_read (int_stream
* s
, void * buf
, size_t * nbytes
)
965 p
= mem_alloc_r_at (s
, &tmp
);
969 memcpy (buf
, p
, *nbytes
);
980 /* Stream write function for internal units. This is not actually used
981 at the moment, as all internal IO is formatted and the formatted IO
982 routines use mem_alloc_w_at. */
985 mem_write (int_stream
* s
, const void * buf
, size_t * nbytes
)
991 p
= mem_alloc_w_at (s
, &tmp
);
995 memcpy (p
, buf
, *nbytes
);
1007 mem_seek (int_stream
* s
, gfc_offset offset
)
1009 if (offset
> s
->file_length
)
1015 s
->logical_offset
= offset
;
1021 mem_set (int_stream
* s
, int c
, size_t n
)
1028 p
= mem_alloc_w_at (s
, &len
);
1040 mem_truncate (int_stream
* s
__attribute__ ((unused
)))
1047 mem_close (int_stream
* s
)
1057 mem_sfree (int_stream
* s
__attribute__ ((unused
)))
1064 /*********************************************************************
1065 Public functions -- A reimplementation of this module needs to
1066 define functional equivalents of the following.
1067 *********************************************************************/
1069 /* empty_internal_buffer()-- Zero the buffer of Internal file */
1072 empty_internal_buffer(stream
*strm
)
1074 int_stream
* s
= (int_stream
*) strm
;
1075 memset(s
->buffer
, ' ', s
->file_length
);
1078 /* open_internal()-- Returns a stream structure from an internal file */
1081 open_internal (char *base
, int length
, gfc_offset offset
)
1085 s
= get_mem (sizeof (int_stream
));
1086 memset (s
, '\0', sizeof (int_stream
));
1089 s
->buffer_offset
= offset
;
1091 s
->logical_offset
= 0;
1092 s
->active
= s
->file_length
= length
;
1094 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
1095 s
->st
.sfree
= (void *) mem_sfree
;
1096 s
->st
.close
= (void *) mem_close
;
1097 s
->st
.seek
= (void *) mem_seek
;
1098 s
->st
.trunc
= (void *) mem_truncate
;
1099 s
->st
.read
= (void *) mem_read
;
1100 s
->st
.write
= (void *) mem_write
;
1101 s
->st
.set
= (void *) mem_set
;
1103 return (stream
*) s
;
1107 /* fd_to_stream()-- Given an open file descriptor, build a stream
1111 fd_to_stream (int fd
, int prot
)
1113 struct stat statbuf
;
1116 s
= get_mem (sizeof (unix_stream
));
1117 memset (s
, '\0', sizeof (unix_stream
));
1120 s
->buffer_offset
= 0;
1121 s
->physical_offset
= 0;
1122 s
->logical_offset
= 0;
1125 /* Get the current length of the file. */
1127 fstat (fd
, &statbuf
);
1129 if (lseek (fd
, 0, SEEK_CUR
) == (off_t
) -1)
1130 s
->file_length
= -1;
1132 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
1134 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
1138 return (stream
*) s
;
1142 /* Given the Fortran unit number, convert it to a C file descriptor. */
1145 unit_to_fd (int unit
)
1150 us
= find_unit (unit
);
1154 fd
= ((unix_stream
*) us
->s
)->fd
;
1160 /* unpack_filename()-- Given a fortran string and a pointer to a
1161 * buffer that is PATH_MAX characters, convert the fortran string to a
1162 * C string in the buffer. Returns nonzero if this is not possible. */
1165 unpack_filename (char *cstring
, const char *fstring
, int len
)
1167 len
= fstrlen (fstring
, len
);
1168 if (len
>= PATH_MAX
)
1171 memmove (cstring
, fstring
, len
);
1172 cstring
[len
] = '\0';
1178 /* tempfile()-- Generate a temporary filename for a scratch file and
1179 * open it. mkstemp() opens the file for reading and writing, but the
1180 * library mode prevents anything that is not allowed. The descriptor
1181 * is returned, which is -1 on error. The template is pointed to by
1182 * opp->file, which is copied into the unit structure
1183 * and freed later. */
1186 tempfile (st_parameter_open
*opp
)
1188 const char *tempdir
;
1192 tempdir
= getenv ("GFORTRAN_TMPDIR");
1193 if (tempdir
== NULL
)
1194 tempdir
= getenv ("TMP");
1195 if (tempdir
== NULL
)
1196 tempdir
= getenv ("TEMP");
1197 if (tempdir
== NULL
)
1198 tempdir
= DEFAULT_TEMPDIR
;
1200 template = get_mem (strlen (tempdir
) + 20);
1202 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
1206 fd
= mkstemp (template);
1208 #else /* HAVE_MKSTEMP */
1210 if (mktemp (template))
1212 #if defined(HAVE_CRLF) && defined(O_BINARY)
1213 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1214 S_IREAD
| S_IWRITE
);
1216 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1218 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
1222 #endif /* HAVE_MKSTEMP */
1225 free_mem (template);
1228 opp
->file
= template;
1229 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1236 /* regular_file()-- Open a regular file.
1237 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1238 * unless an error occurs.
1239 * Returns the descriptor, which is less than zero on error. */
1242 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1244 char path
[PATH_MAX
+ 1];
1250 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1252 errno
= ENOENT
; /* Fake an OS error */
1258 switch (flags
->action
)
1268 case ACTION_READWRITE
:
1269 case ACTION_UNSPECIFIED
:
1274 internal_error (&opp
->common
, "regular_file(): Bad action");
1277 switch (flags
->status
)
1280 crflag
= O_CREAT
| O_EXCL
;
1283 case STATUS_OLD
: /* open will fail if the file does not exist*/
1287 case STATUS_UNKNOWN
:
1288 case STATUS_SCRATCH
:
1292 case STATUS_REPLACE
:
1293 crflag
= O_CREAT
| O_TRUNC
;
1297 internal_error (&opp
->common
, "regular_file(): Bad status");
1300 /* rwflag |= O_LARGEFILE; */
1302 #if defined(HAVE_CRLF) && defined(O_BINARY)
1306 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1307 fd
= open (path
, rwflag
| crflag
, mode
);
1308 if (flags
->action
!= ACTION_UNSPECIFIED
)
1313 flags
->action
= ACTION_READWRITE
;
1316 if (errno
!= EACCES
&& errno
!= EROFS
)
1319 /* retry for read-only access */
1321 fd
= open (path
, rwflag
| crflag
, mode
);
1324 flags
->action
= ACTION_READ
;
1325 return fd
; /* success */
1328 if (errno
!= EACCES
)
1329 return fd
; /* failure */
1331 /* retry for write-only access */
1333 fd
= open (path
, rwflag
| crflag
, mode
);
1336 flags
->action
= ACTION_WRITE
;
1337 return fd
; /* success */
1339 return fd
; /* failure */
1343 /* open_external()-- Open an external file, unix specific version.
1344 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1345 * Returns NULL on operating system error. */
1348 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1352 if (flags
->status
== STATUS_SCRATCH
)
1354 fd
= tempfile (opp
);
1355 if (flags
->action
== ACTION_UNSPECIFIED
)
1356 flags
->action
= ACTION_READWRITE
;
1358 #if HAVE_UNLINK_OPEN_FILE
1359 /* We can unlink scratch files now and it will go away when closed. */
1366 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1368 fd
= regular_file (opp
, flags
);
1375 switch (flags
->action
)
1385 case ACTION_READWRITE
:
1386 prot
= PROT_READ
| PROT_WRITE
;
1390 internal_error (&opp
->common
, "open_external(): Bad action");
1393 return fd_to_stream (fd
, prot
);
1397 /* input_stream()-- Return a stream pointer to the default input stream.
1398 * Called on initialization. */
1403 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1407 /* output_stream()-- Return a stream pointer to the default output stream.
1408 * Called on initialization. */
1411 output_stream (void)
1415 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1416 setmode (STDOUT_FILENO
, O_BINARY
);
1419 s
= fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1420 if (options
.unbuffered_preconnected
)
1421 ((unix_stream
*) s
)->method
= SYNC_UNBUFFERED
;
1426 /* error_stream()-- Return a stream pointer to the default error stream.
1427 * Called on initialization. */
1434 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1435 setmode (STDERR_FILENO
, O_BINARY
);
1438 s
= fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1439 if (options
.unbuffered_preconnected
)
1440 ((unix_stream
*) s
)->method
= SYNC_UNBUFFERED
;
1445 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1446 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1447 is big enough to completely fill a 80x25 terminal, so it shuld be
1448 OK. We use a direct write() because it is simpler and least likely
1449 to be clobbered by memory corruption. Writing an error message
1450 longer than that is an error. */
1452 #define ST_VPRINTF_SIZE 2048
1455 st_vprintf (const char *format
, va_list ap
)
1457 static char buffer
[ST_VPRINTF_SIZE
];
1461 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1462 #ifdef HAVE_VSNPRINTF
1463 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1465 written
= vsprintf(buffer
, format
, ap
);
1467 if (written
>= ST_VPRINTF_SIZE
-1)
1469 /* The error message was longer than our buffer. Ouch. Because
1470 we may have messed up things badly, report the error and
1472 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1473 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1474 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1476 #undef ERROR_MESSAGE
1481 written
= write (fd
, buffer
, written
);
1485 /* st_printf()-- printf() function for error output. This just calls
1486 st_vprintf() to do the actual work. */
1489 st_printf (const char *format
, ...)
1493 va_start (ap
, format
);
1494 written
= st_vprintf(format
, ap
);
1500 /* compare_file_filename()-- Given an open stream and a fortran string
1501 * that is a filename, figure out if the file is the same as the
1505 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1507 char path
[PATH_MAX
+ 1];
1509 #ifdef HAVE_WORKING_STAT
1517 if (unpack_filename (path
, name
, len
))
1518 return 0; /* Can't be the same */
1520 /* If the filename doesn't exist, then there is no match with the
1523 if (stat (path
, &st1
) < 0)
1526 #ifdef HAVE_WORKING_STAT
1527 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1528 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1532 /* We try to match files by a unique ID. On some filesystems (network
1533 fs and FAT), we can't generate this unique ID, and will simply compare
1535 id1
= id_from_path (path
);
1536 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1538 return (id1
== id2
);
1541 if (len
!= u
->file_len
)
1543 return (memcmp(path
, u
->file
, len
) == 0);
1548 #ifdef HAVE_WORKING_STAT
1549 # define FIND_FILE0_DECL struct stat *st
1550 # define FIND_FILE0_ARGS st
1552 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1553 # define FIND_FILE0_ARGS id, file, file_len
1556 /* find_file0()-- Recursive work function for find_file() */
1559 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1562 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1569 #ifdef HAVE_WORKING_STAT
1571 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1572 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1576 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1583 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1587 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1591 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1599 /* find_file()-- Take the current filename and see if there is a unit
1600 * that has the file already open. Returns a pointer to the unit if so. */
1603 find_file (const char *file
, gfc_charlen_type file_len
)
1605 char path
[PATH_MAX
+ 1];
1610 if (unpack_filename (path
, file
, file_len
))
1613 if (stat (path
, &st
[0]) < 0)
1616 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1617 id
= id_from_path (path
);
1622 __gthread_mutex_lock (&unit_lock
);
1624 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1628 if (! __gthread_mutex_trylock (&u
->lock
))
1630 /* assert (u->closed == 0); */
1631 __gthread_mutex_unlock (&unit_lock
);
1635 inc_waiting_locked (u
);
1637 __gthread_mutex_unlock (&unit_lock
);
1640 __gthread_mutex_lock (&u
->lock
);
1643 __gthread_mutex_lock (&unit_lock
);
1644 __gthread_mutex_unlock (&u
->lock
);
1645 if (predec_waiting_locked (u
) == 0)
1650 dec_waiting_unlocked (u
);
1656 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1660 if (u
->unit_number
> min_unit
)
1662 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1666 if (u
->unit_number
>= min_unit
)
1668 if (__gthread_mutex_trylock (&u
->lock
))
1672 __gthread_mutex_unlock (&u
->lock
);
1680 flush_all_units (void)
1685 __gthread_mutex_lock (&unit_lock
);
1688 u
= flush_all_units_1 (unit_root
, min_unit
);
1690 inc_waiting_locked (u
);
1691 __gthread_mutex_unlock (&unit_lock
);
1695 __gthread_mutex_lock (&u
->lock
);
1697 min_unit
= u
->unit_number
+ 1;
1702 __gthread_mutex_lock (&unit_lock
);
1703 __gthread_mutex_unlock (&u
->lock
);
1704 (void) predec_waiting_locked (u
);
1708 __gthread_mutex_lock (&unit_lock
);
1709 __gthread_mutex_unlock (&u
->lock
);
1710 if (predec_waiting_locked (u
) == 0)
1718 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1722 stream_at_bof (stream
* s
)
1726 if (!is_seekable (s
))
1729 us
= (unix_stream
*) s
;
1731 return us
->logical_offset
== 0;
1735 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1739 stream_at_eof (stream
* s
)
1743 if (!is_seekable (s
))
1746 us
= (unix_stream
*) s
;
1748 return us
->logical_offset
== us
->dirty_offset
;
1752 /* delete_file()-- Given a unit structure, delete the file associated
1753 * with the unit. Returns nonzero if something went wrong. */
1756 delete_file (gfc_unit
* u
)
1758 char path
[PATH_MAX
+ 1];
1760 if (unpack_filename (path
, u
->file
, u
->file_len
))
1761 { /* Shouldn't be possible */
1766 return unlink (path
);
1770 /* file_exists()-- Returns nonzero if the current filename exists on
1774 file_exists (const char *file
, gfc_charlen_type file_len
)
1776 char path
[PATH_MAX
+ 1];
1777 struct stat statbuf
;
1779 if (unpack_filename (path
, file
, file_len
))
1782 if (stat (path
, &statbuf
) < 0)
1790 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1792 /* inquire_sequential()-- Given a fortran string, determine if the
1793 * file is suitable for sequential access. Returns a C-style
1797 inquire_sequential (const char *string
, int len
)
1799 char path
[PATH_MAX
+ 1];
1800 struct stat statbuf
;
1802 if (string
== NULL
||
1803 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1806 if (S_ISREG (statbuf
.st_mode
) ||
1807 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1810 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1817 /* inquire_direct()-- Given a fortran string, determine if the file is
1818 * suitable for direct access. Returns a C-style string. */
1821 inquire_direct (const char *string
, int len
)
1823 char path
[PATH_MAX
+ 1];
1824 struct stat statbuf
;
1826 if (string
== NULL
||
1827 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1830 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1833 if (S_ISDIR (statbuf
.st_mode
) ||
1834 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1841 /* inquire_formatted()-- Given a fortran string, determine if the file
1842 * is suitable for formatted form. Returns a C-style string. */
1845 inquire_formatted (const char *string
, int len
)
1847 char path
[PATH_MAX
+ 1];
1848 struct stat statbuf
;
1850 if (string
== NULL
||
1851 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1854 if (S_ISREG (statbuf
.st_mode
) ||
1855 S_ISBLK (statbuf
.st_mode
) ||
1856 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1859 if (S_ISDIR (statbuf
.st_mode
))
1866 /* inquire_unformatted()-- Given a fortran string, determine if the file
1867 * is suitable for unformatted form. Returns a C-style string. */
1870 inquire_unformatted (const char *string
, int len
)
1872 return inquire_formatted (string
, len
);
1886 /* Fallback implementation of access() on systems that don't have it.
1887 Only modes R_OK and W_OK are used in this file. */
1890 fallback_access (const char *path
, int mode
)
1892 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
1895 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
1902 #define access fallback_access
1906 /* inquire_access()-- Given a fortran string, determine if the file is
1907 * suitable for access. */
1910 inquire_access (const char *string
, int len
, int mode
)
1912 char path
[PATH_MAX
+ 1];
1914 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1915 access (path
, mode
) < 0)
1922 /* inquire_read()-- Given a fortran string, determine if the file is
1923 * suitable for READ access. */
1926 inquire_read (const char *string
, int len
)
1928 return inquire_access (string
, len
, R_OK
);
1932 /* inquire_write()-- Given a fortran string, determine if the file is
1933 * suitable for READ access. */
1936 inquire_write (const char *string
, int len
)
1938 return inquire_access (string
, len
, W_OK
);
1942 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1943 * suitable for read and write access. */
1946 inquire_readwrite (const char *string
, int len
)
1948 return inquire_access (string
, len
, R_OK
| W_OK
);
1952 /* file_length()-- Return the file length in bytes, -1 if unknown */
1955 file_length (stream
* s
)
1957 return ((unix_stream
*) s
)->file_length
;
1961 /* file_position()-- Return the current position of the file */
1964 file_position (stream
*s
)
1966 return ((unix_stream
*) s
)->logical_offset
;
1970 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1974 is_seekable (stream
*s
)
1976 /* By convention, if file_length == -1, the file is not
1978 return ((unix_stream
*) s
)->file_length
!=-1;
1982 /* is_special()-- Return nonzero if the stream is not a regular file. */
1985 is_special (stream
*s
)
1987 return ((unix_stream
*) s
)->special_file
;
1994 return fd_flush( (unix_stream
*) s
);
1998 stream_isatty (stream
*s
)
2000 return isatty (((unix_stream
*) s
)->fd
);
2004 stream_ttyname (stream
*s
__attribute__ ((unused
)))
2007 return ttyname (((unix_stream
*) s
)->fd
);
2014 stream_offset (stream
*s
)
2016 return (((unix_stream
*) s
)->logical_offset
);
2020 /* How files are stored: This is an operating-system specific issue,
2021 and therefore belongs here. There are three cases to consider.
2024 Records are written as block of bytes corresponding to the record
2025 length of the file. This goes for both formatted and unformatted
2026 records. Positioning is done explicitly for each data transfer,
2027 so positioning is not much of an issue.
2029 Sequential Formatted:
2030 Records are separated by newline characters. The newline character
2031 is prohibited from appearing in a string. If it does, this will be
2032 messed up on the next read. End of file is also the end of a record.
2034 Sequential Unformatted:
2035 In this case, we are merely copying bytes to and from main storage,
2036 yet we need to keep track of varying record lengths. We adopt
2037 the solution used by f2c. Each record contains a pair of length
2040 Length of record n in bytes
2042 Length of record n in bytes
2044 Length of record n+1 in bytes
2046 Length of record n+1 in bytes
2048 The length is stored at the end of a record to allow backspacing to the
2049 previous record. Between data transfer statements, the file pointer
2050 is left pointing to the first length of the current record.
2052 ENDFILE records are never explicitly stored.