1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 /* Unix stream I/O module */
46 #define SSIZE_MAX SHRT_MAX
61 /* These flags aren't defined on all targets (mingw32), so provide them
80 /* Unix stream I/O module */
82 #define BUFFER_SIZE 8192
89 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
90 gfc_offset physical_offset
; /* Current physical file offset */
91 gfc_offset logical_offset
; /* Current logical file offset */
92 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
93 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
95 int len
; /* Physical length of the current buffer */
96 int active
; /* Length of valid bytes in the buffer */
99 int ndirty
; /* Dirty bytes starting at dirty_offset */
101 int special_file
; /* =1 if the fd refers to a special file */
103 int unbuffered
; /* =1 if the stream is not buffered */
106 char small_buffer
[BUFFER_SIZE
];
111 /* Stream structure for internal files. Fields must be kept in sync
112 with unix_stream above, except for the buffer. For internal files
113 we point the buffer pointer directly at the destination memory. */
120 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
121 gfc_offset physical_offset
; /* Current physical file offset */
122 gfc_offset logical_offset
; /* Current logical file offset */
123 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
124 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
126 int len
; /* Physical length of the current buffer */
127 int active
; /* Length of valid bytes in the buffer */
130 int ndirty
; /* Dirty bytes starting at dirty_offset */
132 int special_file
; /* =1 if the fd refers to a special file */
134 int unbuffered
; /* =1 if the stream is not buffered */
140 /* This implementation of stream I/O is based on the paper:
142 * "Exploiting the advantages of mapped files for stream I/O",
143 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
144 * USENIX conference", p. 27-42.
146 * It differs in a number of ways from the version described in the
147 * paper. First of all, threads are not an issue during I/O and we
148 * also don't have to worry about having multiple regions, since
149 * fortran's I/O model only allows you to be one place at a time.
151 * On the other hand, we have to be able to writing at the end of a
152 * stream, read from the start of a stream or read and write blocks of
153 * bytes from an arbitrary position. After opening a file, a pointer
154 * to a stream structure is returned, which is used to handle file
155 * accesses until the file is closed.
157 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
158 * pointer to a block of memory that mirror the file at position
159 * 'where' that is 'len' bytes long. The len integer is updated to
160 * reflect how many bytes were actually read. The only reason for a
161 * short read is end of file. The file pointer is updated. The
162 * pointer is valid until the next call to salloc_*.
164 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
165 * a pointer to a block of memory that is updated to reflect the state
166 * of the file. The length of the buffer is always equal to that
167 * requested. The buffer must be completely set by the caller. When
168 * data has been written, the sfree() function must be called to
169 * indicate that the caller is done writing data to the buffer. This
170 * may or may not cause a physical write.
172 * Short forms of these are salloc_r() and salloc_w() which drop the
173 * 'where' parameter and use the current file pointer. */
176 /*move_pos_offset()-- Move the record pointer right or left
177 *relative to current position */
180 move_pos_offset (stream
* st
, int pos_off
)
182 unix_stream
* str
= (unix_stream
*)st
;
185 str
->logical_offset
+= pos_off
;
187 if (str
->dirty_offset
+ str
->ndirty
> str
->logical_offset
)
189 if (str
->ndirty
+ pos_off
> 0)
190 str
->ndirty
+= pos_off
;
193 str
->dirty_offset
+= pos_off
+ pos_off
;
204 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
205 * standard descriptors, returning a non-standard descriptor. If the
206 * user specifies that system errors should go to standard output,
207 * then closes standard output, we don't want the system errors to a
208 * file that has been given file descriptor 1 or 0. We want to send
209 * the error to the invalid descriptor. */
215 int input
, output
, error
;
217 input
= output
= error
= 0;
219 /* Unix allocates the lowest descriptors first, so a loop is not
220 required, but this order is. */
221 if (fd
== STDIN_FILENO
)
226 if (fd
== STDOUT_FILENO
)
231 if (fd
== STDERR_FILENO
)
238 close (STDIN_FILENO
);
240 close (STDOUT_FILENO
);
242 close (STDERR_FILENO
);
249 is_preconnected (stream
* s
)
253 fd
= ((unix_stream
*) s
)->fd
;
254 if (fd
== STDIN_FILENO
|| fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
)
260 /* If the stream corresponds to a preconnected unit, we flush the
261 corresponding C stream. This is bugware for mixed C-Fortran codes
262 where the C code doesn't flush I/O before returning. */
264 flush_if_preconnected (stream
* s
)
268 fd
= ((unix_stream
*) s
)->fd
;
269 if (fd
== STDIN_FILENO
)
271 else if (fd
== STDOUT_FILENO
)
273 else if (fd
== STDERR_FILENO
)
278 /* Reset a stream after reading/writing. Assumes that the buffers have
282 reset_stream (unix_stream
* s
, size_t bytes_rw
)
284 s
->physical_offset
+= bytes_rw
;
285 s
->logical_offset
= s
->physical_offset
;
286 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
287 s
->file_length
= s
->physical_offset
;
291 /* Read bytes into a buffer, allowing for short reads. If the nbytes
292 * argument is less on return than on entry, it is because we've hit
293 * the end of file. */
296 do_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
304 bytes_left
= *nbytes
;
305 buf_st
= (char *) buf
;
307 /* We must read in a loop since some systems don't restart system
308 calls in case of a signal. */
309 while (bytes_left
> 0)
311 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
312 so we must read in chunks smaller than SSIZE_MAX. */
313 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
314 trans
= read (s
->fd
, buf_st
, trans
);
325 else if (trans
== 0) /* We hit EOF. */
331 *nbytes
-= bytes_left
;
336 /* Write a buffer to a stream, allowing for short writes. */
339 do_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
347 bytes_left
= *nbytes
;
348 buf_st
= (char *) buf
;
350 /* We must write in a loop since some systems don't restart system
351 calls in case of a signal. */
352 while (bytes_left
> 0)
354 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
355 so we must write in chunks smaller than SSIZE_MAX. */
356 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
357 trans
= write (s
->fd
, buf_st
, trans
);
372 *nbytes
-= bytes_left
;
377 /* get_oserror()-- Get the most recent operating system error. For
378 * unix, this is errno. */
383 return strerror (errno
);
387 /*********************************************************************
388 File descriptor stream functions
389 *********************************************************************/
392 /* fd_flush()-- Write bytes that need to be written */
395 fd_flush (unix_stream
* s
)
402 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->dirty_offset
&&
403 lseek (s
->fd
, s
->dirty_offset
, SEEK_SET
) < 0)
406 writelen
= s
->ndirty
;
407 if (do_write (s
, s
->buffer
+ (s
->dirty_offset
- s
->buffer_offset
),
411 s
->physical_offset
= s
->dirty_offset
+ writelen
;
413 /* don't increment file_length if the file is non-seekable */
414 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
415 s
->file_length
= s
->physical_offset
;
417 s
->ndirty
-= writelen
;
425 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
426 * satisfied. This subroutine gets the buffer ready for whatever is
430 fd_alloc (unix_stream
* s
, gfc_offset where
,
431 int *len
__attribute__ ((unused
)))
436 if (*len
<= BUFFER_SIZE
)
438 new_buffer
= s
->small_buffer
;
439 read_len
= BUFFER_SIZE
;
443 new_buffer
= get_mem (*len
);
447 /* Salvage bytes currently within the buffer. This is important for
448 * devices that cannot seek. */
450 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
451 where
<= s
->buffer_offset
+ s
->active
)
454 n
= s
->active
- (where
- s
->buffer_offset
);
455 memmove (new_buffer
, s
->buffer
+ (where
- s
->buffer_offset
), n
);
460 { /* new buffer starts off empty */
464 s
->buffer_offset
= where
;
466 /* free the old buffer if necessary */
468 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
469 free_mem (s
->buffer
);
471 s
->buffer
= new_buffer
;
476 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
477 * we've already buffered the data or we need to load it. Returns
478 * NULL on I/O error. */
481 fd_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
486 where
= s
->logical_offset
;
488 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
489 where
+ *len
<= s
->buffer_offset
+ s
->active
)
492 /* Return a position within the current buffer */
494 s
->logical_offset
= where
+ *len
;
495 return s
->buffer
+ where
- s
->buffer_offset
;
498 fd_alloc (s
, where
, len
);
500 m
= where
+ s
->active
;
502 if (s
->physical_offset
!= m
&& lseek (s
->fd
, m
, SEEK_SET
) < 0)
505 /* do_read() hangs on read from terminals for *BSD-systems. Only
506 use read() in that case. */
512 n
= read (s
->fd
, s
->buffer
+ s
->active
, s
->len
- s
->active
);
516 s
->physical_offset
= m
+ n
;
523 n
= s
->len
- s
->active
;
524 if (do_read (s
, s
->buffer
+ s
->active
, &n
) != 0)
527 s
->physical_offset
= m
+ n
;
531 if (s
->active
< *len
)
532 *len
= s
->active
; /* Bytes actually available */
534 s
->logical_offset
= where
+ *len
;
540 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
541 * we've already buffered the data or we need to load it. */
544 fd_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
549 where
= s
->logical_offset
;
551 if (s
->buffer
== NULL
|| s
->buffer_offset
> where
||
552 where
+ *len
> s
->buffer_offset
+ s
->len
)
555 if (fd_flush (s
) == FAILURE
)
557 fd_alloc (s
, where
, len
);
560 /* Return a position within the current buffer */
562 || where
> s
->dirty_offset
+ s
->ndirty
563 || s
->dirty_offset
> where
+ *len
)
564 { /* Discontiguous blocks, start with a clean buffer. */
565 /* Flush the buffer. */
568 s
->dirty_offset
= where
;
573 gfc_offset start
; /* Merge with the existing data. */
574 if (where
< s
->dirty_offset
)
577 start
= s
->dirty_offset
;
578 if (where
+ *len
> s
->dirty_offset
+ s
->ndirty
)
579 s
->ndirty
= where
+ *len
- start
;
581 s
->ndirty
= s
->dirty_offset
+ s
->ndirty
- start
;
582 s
->dirty_offset
= start
;
585 s
->logical_offset
= where
+ *len
;
587 /* Don't increment file_length if the file is non-seekable. */
589 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
590 s
->file_length
= s
->logical_offset
;
592 n
= s
->logical_offset
- s
->buffer_offset
;
596 return s
->buffer
+ where
- s
->buffer_offset
;
601 fd_sfree (unix_stream
* s
)
603 if (s
->ndirty
!= 0 &&
604 (s
->buffer
!= s
->small_buffer
|| options
.all_unbuffered
||
613 fd_seek (unix_stream
* s
, gfc_offset offset
)
616 if (s
->file_length
== -1)
619 if (s
->physical_offset
== offset
) /* Are we lucky and avoid syscall? */
621 s
->logical_offset
= offset
;
625 if (lseek (s
->fd
, offset
, SEEK_SET
) >= 0)
627 s
->physical_offset
= s
->logical_offset
= offset
;
636 /* truncate_file()-- Given a unit, truncate the file at the current
637 * position. Sets the physical location to the new end of the file.
638 * Returns nonzero on error. */
641 fd_truncate (unix_stream
* s
)
643 /* Non-seekable files, like terminals and fifo's fail the lseek so just
644 return success, there is nothing to truncate. If its not a pipe there
645 is a real problem. */
646 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) == -1)
654 /* Using ftruncate on a seekable special file (like /dev/null)
655 is undefined, so we treat it as if the ftruncate succeeded. */
656 #ifdef HAVE_FTRUNCATE
657 if (s
->special_file
|| ftruncate (s
->fd
, s
->logical_offset
))
660 if (s
->special_file
|| chsize (s
->fd
, s
->logical_offset
))
664 s
->physical_offset
= s
->file_length
= 0;
668 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
674 /* Similar to memset(), but operating on a stream instead of a string.
675 Takes care of not using too much memory. */
678 fd_sset (unix_stream
* s
, int c
, size_t n
)
686 while (bytes_left
> 0)
688 /* memset() in chunks of BUFFER_SIZE. */
689 trans
= (bytes_left
< BUFFER_SIZE
) ? bytes_left
: BUFFER_SIZE
;
691 p
= fd_alloc_w_at (s
, &trans
, -1);
693 memset (p
, c
, trans
);
704 /* Stream read function. Avoids using a buffer for big reads. The
705 interface is like POSIX read(), but the nbytes argument is a
706 pointer; on return it contains the number of bytes written. The
707 function return value is the status indicator (0 for success). */
710 fd_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
715 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
718 p
= fd_alloc_r_at (s
, &tmp
, -1);
722 memcpy (buf
, p
, *nbytes
);
732 /* If the request is bigger than BUFFER_SIZE we flush the buffers
733 and read directly. */
734 if (fd_flush (s
) == FAILURE
)
740 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
746 status
= do_read (s
, buf
, nbytes
);
747 reset_stream (s
, *nbytes
);
752 /* Stream write function. Avoids using a buffer for big writes. The
753 interface is like POSIX write(), but the nbytes argument is a
754 pointer; on return it contains the number of bytes written. The
755 function return value is the status indicator (0 for success). */
758 fd_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
763 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
766 p
= fd_alloc_w_at (s
, &tmp
, -1);
770 memcpy (p
, buf
, *nbytes
);
780 /* If the request is bigger than BUFFER_SIZE we flush the buffers
781 and write directly. */
782 if (fd_flush (s
) == FAILURE
)
788 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
794 status
= do_write (s
, buf
, nbytes
);
795 reset_stream (s
, *nbytes
);
801 fd_close (unix_stream
* s
)
803 if (fd_flush (s
) == FAILURE
)
806 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
807 free_mem (s
->buffer
);
809 if (s
->fd
!= STDOUT_FILENO
&& s
->fd
!= STDERR_FILENO
)
811 if (close (s
->fd
) < 0)
822 fd_open (unix_stream
* s
)
827 s
->st
.alloc_r_at
= (void *) fd_alloc_r_at
;
828 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
829 s
->st
.sfree
= (void *) fd_sfree
;
830 s
->st
.close
= (void *) fd_close
;
831 s
->st
.seek
= (void *) fd_seek
;
832 s
->st
.trunc
= (void *) fd_truncate
;
833 s
->st
.read
= (void *) fd_read
;
834 s
->st
.write
= (void *) fd_write
;
835 s
->st
.set
= (void *) fd_sset
;
843 /*********************************************************************
844 memory stream functions - These are used for internal files
846 The idea here is that a single stream structure is created and all
847 requests must be satisfied from it. The location and size of the
848 buffer is the character variable supplied to the READ or WRITE
851 *********************************************************************/
855 mem_alloc_r_at (int_stream
* s
, int *len
, gfc_offset where
)
860 where
= s
->logical_offset
;
862 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
865 s
->logical_offset
= where
+ *len
;
867 n
= s
->buffer_offset
+ s
->active
- where
;
871 return s
->buffer
+ (where
- s
->buffer_offset
);
876 mem_alloc_w_at (int_stream
* s
, int *len
, gfc_offset where
)
880 assert (*len
>= 0); /* Negative values not allowed. */
883 where
= s
->logical_offset
;
887 if (where
< s
->buffer_offset
)
890 if (m
> s
->file_length
)
893 s
->logical_offset
= m
;
895 return s
->buffer
+ (where
- s
->buffer_offset
);
899 /* Stream read function for internal units. This is not actually used
900 at the moment, as all internal IO is formatted and the formatted IO
901 routines use mem_alloc_r_at. */
904 mem_read (int_stream
* s
, void * buf
, size_t * nbytes
)
910 p
= mem_alloc_r_at (s
, &tmp
, -1);
914 memcpy (buf
, p
, *nbytes
);
925 /* Stream write function for internal units. This is not actually used
926 at the moment, as all internal IO is formatted and the formatted IO
927 routines use mem_alloc_w_at. */
930 mem_write (int_stream
* s
, const void * buf
, size_t * nbytes
)
938 p
= mem_alloc_w_at (s
, &tmp
, -1);
942 memcpy (p
, buf
, *nbytes
);
954 mem_seek (int_stream
* s
, gfc_offset offset
)
956 if (offset
> s
->file_length
)
962 s
->logical_offset
= offset
;
968 mem_set (int_stream
* s
, int c
, size_t n
)
975 p
= mem_alloc_w_at (s
, &len
, -1);
987 mem_truncate (int_stream
* s
__attribute__ ((unused
)))
994 mem_close (int_stream
* s
)
1004 mem_sfree (int_stream
* s
__attribute__ ((unused
)))
1011 /*********************************************************************
1012 Public functions -- A reimplementation of this module needs to
1013 define functional equivalents of the following.
1014 *********************************************************************/
1016 /* empty_internal_buffer()-- Zero the buffer of Internal file */
1019 empty_internal_buffer(stream
*strm
)
1021 int_stream
* s
= (int_stream
*) strm
;
1022 memset(s
->buffer
, ' ', s
->file_length
);
1025 /* open_internal()-- Returns a stream structure from an internal file */
1028 open_internal (char *base
, int length
)
1032 s
= get_mem (sizeof (int_stream
));
1033 memset (s
, '\0', sizeof (int_stream
));
1036 s
->buffer_offset
= 0;
1038 s
->logical_offset
= 0;
1039 s
->active
= s
->file_length
= length
;
1041 s
->st
.alloc_r_at
= (void *) mem_alloc_r_at
;
1042 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
1043 s
->st
.sfree
= (void *) mem_sfree
;
1044 s
->st
.close
= (void *) mem_close
;
1045 s
->st
.seek
= (void *) mem_seek
;
1046 s
->st
.trunc
= (void *) mem_truncate
;
1047 s
->st
.read
= (void *) mem_read
;
1048 s
->st
.write
= (void *) mem_write
;
1049 s
->st
.set
= (void *) mem_set
;
1051 return (stream
*) s
;
1055 /* fd_to_stream()-- Given an open file descriptor, build a stream
1059 fd_to_stream (int fd
, int prot
)
1061 struct stat statbuf
;
1064 s
= get_mem (sizeof (unix_stream
));
1065 memset (s
, '\0', sizeof (unix_stream
));
1068 s
->buffer_offset
= 0;
1069 s
->physical_offset
= 0;
1070 s
->logical_offset
= 0;
1073 /* Get the current length of the file. */
1075 fstat (fd
, &statbuf
);
1077 if (lseek (fd
, 0, SEEK_CUR
) == (off_t
) -1)
1078 s
->file_length
= -1;
1080 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
1082 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
1086 return (stream
*) s
;
1090 /* Given the Fortran unit number, convert it to a C file descriptor. */
1093 unit_to_fd (int unit
)
1098 us
= find_unit (unit
);
1102 fd
= ((unix_stream
*) us
->s
)->fd
;
1108 /* unpack_filename()-- Given a fortran string and a pointer to a
1109 * buffer that is PATH_MAX characters, convert the fortran string to a
1110 * C string in the buffer. Returns nonzero if this is not possible. */
1113 unpack_filename (char *cstring
, const char *fstring
, int len
)
1115 len
= fstrlen (fstring
, len
);
1116 if (len
>= PATH_MAX
)
1119 memmove (cstring
, fstring
, len
);
1120 cstring
[len
] = '\0';
1126 /* tempfile()-- Generate a temporary filename for a scratch file and
1127 * open it. mkstemp() opens the file for reading and writing, but the
1128 * library mode prevents anything that is not allowed. The descriptor
1129 * is returned, which is -1 on error. The template is pointed to by
1130 * opp->file, which is copied into the unit structure
1131 * and freed later. */
1134 tempfile (st_parameter_open
*opp
)
1136 const char *tempdir
;
1140 tempdir
= getenv ("GFORTRAN_TMPDIR");
1141 if (tempdir
== NULL
)
1142 tempdir
= getenv ("TMP");
1143 if (tempdir
== NULL
)
1144 tempdir
= getenv ("TEMP");
1145 if (tempdir
== NULL
)
1146 tempdir
= DEFAULT_TEMPDIR
;
1148 template = get_mem (strlen (tempdir
) + 20);
1150 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
1154 fd
= mkstemp (template);
1156 #else /* HAVE_MKSTEMP */
1158 if (mktemp (template))
1160 #if defined(HAVE_CRLF) && defined(O_BINARY)
1161 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1162 S_IREAD
| S_IWRITE
);
1164 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1166 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
1170 #endif /* HAVE_MKSTEMP */
1173 free_mem (template);
1176 opp
->file
= template;
1177 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1184 /* regular_file()-- Open a regular file.
1185 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1186 * unless an error occurs.
1187 * Returns the descriptor, which is less than zero on error. */
1190 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1192 char path
[PATH_MAX
+ 1];
1198 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1200 errno
= ENOENT
; /* Fake an OS error */
1206 switch (flags
->action
)
1216 case ACTION_READWRITE
:
1217 case ACTION_UNSPECIFIED
:
1222 internal_error (&opp
->common
, "regular_file(): Bad action");
1225 switch (flags
->status
)
1228 crflag
= O_CREAT
| O_EXCL
;
1231 case STATUS_OLD
: /* open will fail if the file does not exist*/
1235 case STATUS_UNKNOWN
:
1236 case STATUS_SCRATCH
:
1240 case STATUS_REPLACE
:
1241 crflag
= O_CREAT
| O_TRUNC
;
1245 internal_error (&opp
->common
, "regular_file(): Bad status");
1248 /* rwflag |= O_LARGEFILE; */
1250 #if defined(HAVE_CRLF) && defined(O_BINARY)
1254 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1255 fd
= open (path
, rwflag
| crflag
, mode
);
1256 if (flags
->action
!= ACTION_UNSPECIFIED
)
1261 flags
->action
= ACTION_READWRITE
;
1264 if (errno
!= EACCES
&& errno
!= EROFS
)
1267 /* retry for read-only access */
1269 fd
= open (path
, rwflag
| crflag
, mode
);
1272 flags
->action
= ACTION_READ
;
1273 return fd
; /* success */
1276 if (errno
!= EACCES
)
1277 return fd
; /* failure */
1279 /* retry for write-only access */
1281 fd
= open (path
, rwflag
| crflag
, mode
);
1284 flags
->action
= ACTION_WRITE
;
1285 return fd
; /* success */
1287 return fd
; /* failure */
1291 /* open_external()-- Open an external file, unix specific version.
1292 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1293 * Returns NULL on operating system error. */
1296 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1300 if (flags
->status
== STATUS_SCRATCH
)
1302 fd
= tempfile (opp
);
1303 if (flags
->action
== ACTION_UNSPECIFIED
)
1304 flags
->action
= ACTION_READWRITE
;
1306 #if HAVE_UNLINK_OPEN_FILE
1307 /* We can unlink scratch files now and it will go away when closed. */
1314 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1316 fd
= regular_file (opp
, flags
);
1323 switch (flags
->action
)
1333 case ACTION_READWRITE
:
1334 prot
= PROT_READ
| PROT_WRITE
;
1338 internal_error (&opp
->common
, "open_external(): Bad action");
1341 return fd_to_stream (fd
, prot
);
1345 /* input_stream()-- Return a stream pointer to the default input stream.
1346 * Called on initialization. */
1351 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1355 /* output_stream()-- Return a stream pointer to the default output stream.
1356 * Called on initialization. */
1359 output_stream (void)
1361 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1362 setmode (STDOUT_FILENO
, O_BINARY
);
1364 return fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1368 /* error_stream()-- Return a stream pointer to the default error stream.
1369 * Called on initialization. */
1374 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1375 setmode (STDERR_FILENO
, O_BINARY
);
1377 return fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1381 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1382 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1383 is big enough to completely fill a 80x25 terminal, so it shuld be
1384 OK. We use a direct write() because it is simpler and least likely
1385 to be clobbered by memory corruption. Writing an error message
1386 longer than that is an error. */
1388 #define ST_VPRINTF_SIZE 2048
1391 st_vprintf (const char *format
, va_list ap
)
1393 static char buffer
[ST_VPRINTF_SIZE
];
1397 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1398 #ifdef HAVE_VSNPRINTF
1399 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1401 written
= vsprintf(buffer
, format
, ap
);
1403 if (written
>= ST_VPRINTF_SIZE
-1)
1405 /* The error message was longer than our buffer. Ouch. Because
1406 we may have messed up things badly, report the error and
1408 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1409 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1410 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1412 #undef ERROR_MESSAGE
1417 written
= write (fd
, buffer
, written
);
1421 /* st_printf()-- printf() function for error output. This just calls
1422 st_vprintf() to do the actual work. */
1425 st_printf (const char *format
, ...)
1429 va_start (ap
, format
);
1430 written
= st_vprintf(format
, ap
);
1436 /* compare_file_filename()-- Given an open stream and a fortran string
1437 * that is a filename, figure out if the file is the same as the
1441 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1443 char path
[PATH_MAX
+ 1];
1445 #ifdef HAVE_WORKING_STAT
1449 if (unpack_filename (path
, name
, len
))
1450 return 0; /* Can't be the same */
1452 /* If the filename doesn't exist, then there is no match with the
1455 if (stat (path
, &st1
) < 0)
1458 #ifdef HAVE_WORKING_STAT
1459 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1460 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1462 if (len
!= u
->file_len
)
1464 return (memcmp(path
, u
->file
, len
) == 0);
1469 #ifdef HAVE_WORKING_STAT
1470 # define FIND_FILE0_DECL struct stat *st
1471 # define FIND_FILE0_ARGS st
1473 # define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
1474 # define FIND_FILE0_ARGS file, file_len
1477 /* find_file0()-- Recursive work function for find_file() */
1480 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1487 #ifdef HAVE_WORKING_STAT
1489 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1490 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1493 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1497 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1501 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1509 /* find_file()-- Take the current filename and see if there is a unit
1510 * that has the file already open. Returns a pointer to the unit if so. */
1513 find_file (const char *file
, gfc_charlen_type file_len
)
1515 char path
[PATH_MAX
+ 1];
1519 if (unpack_filename (path
, file
, file_len
))
1522 if (stat (path
, &st
[0]) < 0)
1525 __gthread_mutex_lock (&unit_lock
);
1527 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1531 if (! __gthread_mutex_trylock (&u
->lock
))
1533 /* assert (u->closed == 0); */
1534 __gthread_mutex_unlock (&unit_lock
);
1538 inc_waiting_locked (u
);
1540 __gthread_mutex_unlock (&unit_lock
);
1543 __gthread_mutex_lock (&u
->lock
);
1546 __gthread_mutex_lock (&unit_lock
);
1547 __gthread_mutex_unlock (&u
->lock
);
1548 if (predec_waiting_locked (u
) == 0)
1553 dec_waiting_unlocked (u
);
1559 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1563 if (u
->unit_number
> min_unit
)
1565 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1569 if (u
->unit_number
>= min_unit
)
1571 if (__gthread_mutex_trylock (&u
->lock
))
1575 __gthread_mutex_unlock (&u
->lock
);
1583 flush_all_units (void)
1588 __gthread_mutex_lock (&unit_lock
);
1591 u
= flush_all_units_1 (unit_root
, min_unit
);
1593 inc_waiting_locked (u
);
1594 __gthread_mutex_unlock (&unit_lock
);
1598 __gthread_mutex_lock (&u
->lock
);
1600 min_unit
= u
->unit_number
+ 1;
1605 __gthread_mutex_lock (&unit_lock
);
1606 __gthread_mutex_unlock (&u
->lock
);
1607 (void) predec_waiting_locked (u
);
1611 __gthread_mutex_lock (&unit_lock
);
1612 __gthread_mutex_unlock (&u
->lock
);
1613 if (predec_waiting_locked (u
) == 0)
1621 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1625 stream_at_bof (stream
* s
)
1629 if (!is_seekable (s
))
1632 us
= (unix_stream
*) s
;
1634 return us
->logical_offset
== 0;
1638 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1642 stream_at_eof (stream
* s
)
1646 if (!is_seekable (s
))
1649 us
= (unix_stream
*) s
;
1651 return us
->logical_offset
== us
->dirty_offset
;
1655 /* delete_file()-- Given a unit structure, delete the file associated
1656 * with the unit. Returns nonzero if something went wrong. */
1659 delete_file (gfc_unit
* u
)
1661 char path
[PATH_MAX
+ 1];
1663 if (unpack_filename (path
, u
->file
, u
->file_len
))
1664 { /* Shouldn't be possible */
1669 return unlink (path
);
1673 /* file_exists()-- Returns nonzero if the current filename exists on
1677 file_exists (const char *file
, gfc_charlen_type file_len
)
1679 char path
[PATH_MAX
+ 1];
1680 struct stat statbuf
;
1682 if (unpack_filename (path
, file
, file_len
))
1685 if (stat (path
, &statbuf
) < 0)
1693 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1695 /* inquire_sequential()-- Given a fortran string, determine if the
1696 * file is suitable for sequential access. Returns a C-style
1700 inquire_sequential (const char *string
, int len
)
1702 char path
[PATH_MAX
+ 1];
1703 struct stat statbuf
;
1705 if (string
== NULL
||
1706 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1709 if (S_ISREG (statbuf
.st_mode
) ||
1710 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1713 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1720 /* inquire_direct()-- Given a fortran string, determine if the file is
1721 * suitable for direct access. Returns a C-style string. */
1724 inquire_direct (const char *string
, int len
)
1726 char path
[PATH_MAX
+ 1];
1727 struct stat statbuf
;
1729 if (string
== NULL
||
1730 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1733 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1736 if (S_ISDIR (statbuf
.st_mode
) ||
1737 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1744 /* inquire_formatted()-- Given a fortran string, determine if the file
1745 * is suitable for formatted form. Returns a C-style string. */
1748 inquire_formatted (const char *string
, int len
)
1750 char path
[PATH_MAX
+ 1];
1751 struct stat statbuf
;
1753 if (string
== NULL
||
1754 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1757 if (S_ISREG (statbuf
.st_mode
) ||
1758 S_ISBLK (statbuf
.st_mode
) ||
1759 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1762 if (S_ISDIR (statbuf
.st_mode
))
1769 /* inquire_unformatted()-- Given a fortran string, determine if the file
1770 * is suitable for unformatted form. Returns a C-style string. */
1773 inquire_unformatted (const char *string
, int len
)
1775 return inquire_formatted (string
, len
);
1789 /* Fallback implementation of access() on systems that don't have it.
1790 Only modes R_OK and W_OK are used in this file. */
1793 fallback_access (const char *path
, int mode
)
1795 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
1798 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
1805 #define access fallback_access
1809 /* inquire_access()-- Given a fortran string, determine if the file is
1810 * suitable for access. */
1813 inquire_access (const char *string
, int len
, int mode
)
1815 char path
[PATH_MAX
+ 1];
1817 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1818 access (path
, mode
) < 0)
1825 /* inquire_read()-- Given a fortran string, determine if the file is
1826 * suitable for READ access. */
1829 inquire_read (const char *string
, int len
)
1831 return inquire_access (string
, len
, R_OK
);
1835 /* inquire_write()-- Given a fortran string, determine if the file is
1836 * suitable for READ access. */
1839 inquire_write (const char *string
, int len
)
1841 return inquire_access (string
, len
, W_OK
);
1845 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1846 * suitable for read and write access. */
1849 inquire_readwrite (const char *string
, int len
)
1851 return inquire_access (string
, len
, R_OK
| W_OK
);
1855 /* file_length()-- Return the file length in bytes, -1 if unknown */
1858 file_length (stream
* s
)
1860 return ((unix_stream
*) s
)->file_length
;
1864 /* file_position()-- Return the current position of the file */
1867 file_position (stream
*s
)
1869 return ((unix_stream
*) s
)->logical_offset
;
1873 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1877 is_seekable (stream
*s
)
1879 /* By convention, if file_length == -1, the file is not
1881 return ((unix_stream
*) s
)->file_length
!=-1;
1885 /* is_special()-- Return nonzero if the stream is not a regular file. */
1888 is_special (stream
*s
)
1890 return ((unix_stream
*) s
)->special_file
;
1897 return fd_flush( (unix_stream
*) s
);
1901 stream_isatty (stream
*s
)
1903 return isatty (((unix_stream
*) s
)->fd
);
1907 stream_ttyname (stream
*s
__attribute__ ((unused
)))
1910 return ttyname (((unix_stream
*) s
)->fd
);
1917 stream_offset (stream
*s
)
1919 return (((unix_stream
*) s
)->logical_offset
);
1923 /* How files are stored: This is an operating-system specific issue,
1924 and therefore belongs here. There are three cases to consider.
1927 Records are written as block of bytes corresponding to the record
1928 length of the file. This goes for both formatted and unformatted
1929 records. Positioning is done explicitly for each data transfer,
1930 so positioning is not much of an issue.
1932 Sequential Formatted:
1933 Records are separated by newline characters. The newline character
1934 is prohibited from appearing in a string. If it does, this will be
1935 messed up on the next read. End of file is also the end of a record.
1937 Sequential Unformatted:
1938 In this case, we are merely copying bytes to and from main storage,
1939 yet we need to keep track of varying record lengths. We adopt
1940 the solution used by f2c. Each record contains a pair of length
1943 Length of record n in bytes
1945 Length of record n in bytes
1947 Length of record n+1 in bytes
1949 Length of record n+1 in bytes
1951 The length is stored at the end of a record to allow backspacing to the
1952 previous record. Between data transfer statements, the file pointer
1953 is left pointing to the first length of the current record.
1955 ENDFILE records are never explicitly stored.