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 */
47 #include "libgfortran.h"
51 #define SSIZE_MAX SHRT_MAX
66 /* These flags aren't defined on all targets (mingw32), so provide them
85 /* Unix stream I/O module */
87 #define BUFFER_SIZE 8192
94 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
95 gfc_offset physical_offset
; /* Current physical file offset */
96 gfc_offset logical_offset
; /* Current logical file offset */
97 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
98 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
101 int len
; /* Physical length of the current buffer */
102 int active
; /* Length of valid bytes in the buffer */
105 int ndirty
; /* Dirty bytes starting at dirty_offset */
107 int special_file
; /* =1 if the fd refers to a special file */
109 unsigned unbuffered
:1;
111 char small_buffer
[BUFFER_SIZE
];
116 extern stream
*init_error_stream (unix_stream
*);
117 internal_proto(init_error_stream
);
120 /* This implementation of stream I/O is based on the paper:
122 * "Exploiting the advantages of mapped files for stream I/O",
123 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
124 * USENIX conference", p. 27-42.
126 * It differs in a number of ways from the version described in the
127 * paper. First of all, threads are not an issue during I/O and we
128 * also don't have to worry about having multiple regions, since
129 * fortran's I/O model only allows you to be one place at a time.
131 * On the other hand, we have to be able to writing at the end of a
132 * stream, read from the start of a stream or read and write blocks of
133 * bytes from an arbitrary position. After opening a file, a pointer
134 * to a stream structure is returned, which is used to handle file
135 * accesses until the file is closed.
137 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
138 * pointer to a block of memory that mirror the file at position
139 * 'where' that is 'len' bytes long. The len integer is updated to
140 * reflect how many bytes were actually read. The only reason for a
141 * short read is end of file. The file pointer is updated. The
142 * pointer is valid until the next call to salloc_*.
144 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
145 * a pointer to a block of memory that is updated to reflect the state
146 * of the file. The length of the buffer is always equal to that
147 * requested. The buffer must be completely set by the caller. When
148 * data has been written, the sfree() function must be called to
149 * indicate that the caller is done writing data to the buffer. This
150 * may or may not cause a physical write.
152 * Short forms of these are salloc_r() and salloc_w() which drop the
153 * 'where' parameter and use the current file pointer. */
156 /*move_pos_offset()-- Move the record pointer right or left
157 *relative to current position */
160 move_pos_offset (stream
* st
, int pos_off
)
162 unix_stream
* str
= (unix_stream
*)st
;
165 str
->logical_offset
+= pos_off
;
167 if (str
->dirty_offset
+ str
->ndirty
> str
->logical_offset
)
169 if (str
->ndirty
+ pos_off
> 0)
170 str
->ndirty
+= pos_off
;
173 str
->dirty_offset
+= pos_off
+ pos_off
;
184 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
185 * standard descriptors, returning a non-standard descriptor. If the
186 * user specifies that system errors should go to standard output,
187 * then closes standard output, we don't want the system errors to a
188 * file that has been given file descriptor 1 or 0. We want to send
189 * the error to the invalid descriptor. */
194 int input
, output
, error
;
196 input
= output
= error
= 0;
198 /* Unix allocates the lowest descriptors first, so a loop is not
199 required, but this order is. */
201 if (fd
== STDIN_FILENO
)
206 if (fd
== STDOUT_FILENO
)
211 if (fd
== STDERR_FILENO
)
218 close (STDIN_FILENO
);
220 close (STDOUT_FILENO
);
222 close (STDERR_FILENO
);
228 is_preconnected (stream
* s
)
232 fd
= ((unix_stream
*) s
)->fd
;
233 if (fd
== STDIN_FILENO
|| fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
)
239 /* If the stream corresponds to a preconnected unit, we flush the
240 corresponding C stream. This is bugware for mixed C-Fortran codes
241 where the C code doesn't flush I/O before returning. */
243 flush_if_preconnected (stream
* s
)
247 fd
= ((unix_stream
*) s
)->fd
;
248 if (fd
== STDIN_FILENO
)
250 else if (fd
== STDOUT_FILENO
)
252 else if (fd
== STDERR_FILENO
)
257 /* Reset a stream after reading/writing. Assumes that the buffers have
261 reset_stream (unix_stream
* s
, size_t bytes_rw
)
263 s
->physical_offset
+= bytes_rw
;
264 s
->logical_offset
= s
->physical_offset
;
265 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
266 s
->file_length
= s
->physical_offset
;
270 /* Read bytes into a buffer, allowing for short reads. If the nbytes
271 * argument is less on return than on entry, it is because we've hit
272 * the end of file. */
275 do_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
283 bytes_left
= *nbytes
;
284 buf_st
= (char *) buf
;
286 /* We must read in a loop since some systems don't restart system
287 calls in case of a signal. */
288 while (bytes_left
> 0)
290 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
291 so we must read in chunks smaller than SSIZE_MAX. */
292 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
293 trans
= read (s
->fd
, buf_st
, trans
);
304 else if (trans
== 0) /* We hit EOF. */
310 *nbytes
-= bytes_left
;
315 /* Write a buffer to a stream, allowing for short writes. */
318 do_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
326 bytes_left
= *nbytes
;
327 buf_st
= (char *) buf
;
329 /* We must write in a loop since some systems don't restart system
330 calls in case of a signal. */
331 while (bytes_left
> 0)
333 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
334 so we must write in chunks smaller than SSIZE_MAX. */
335 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
336 trans
= write (s
->fd
, buf_st
, trans
);
351 *nbytes
-= bytes_left
;
356 /* get_oserror()-- Get the most recent operating system error. For
357 * unix, this is errno. */
362 return strerror (errno
);
366 /*********************************************************************
367 File descriptor stream functions
368 *********************************************************************/
371 /* fd_flush()-- Write bytes that need to be written */
374 fd_flush (unix_stream
* s
)
381 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->dirty_offset
&&
382 lseek (s
->fd
, s
->dirty_offset
, SEEK_SET
) < 0)
385 writelen
= s
->ndirty
;
386 if (do_write (s
, s
->buffer
+ (s
->dirty_offset
- s
->buffer_offset
),
390 s
->physical_offset
= s
->dirty_offset
+ writelen
;
392 /* don't increment file_length if the file is non-seekable */
393 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
394 s
->file_length
= s
->physical_offset
;
396 s
->ndirty
-= writelen
;
404 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
405 * satisfied. This subroutine gets the buffer ready for whatever is
409 fd_alloc (unix_stream
* s
, gfc_offset where
,
410 int *len
__attribute__ ((unused
)))
415 if (*len
<= BUFFER_SIZE
)
417 new_buffer
= s
->small_buffer
;
418 read_len
= BUFFER_SIZE
;
422 new_buffer
= get_mem (*len
);
426 /* Salvage bytes currently within the buffer. This is important for
427 * devices that cannot seek. */
429 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
430 where
<= s
->buffer_offset
+ s
->active
)
433 n
= s
->active
- (where
- s
->buffer_offset
);
434 memmove (new_buffer
, s
->buffer
+ (where
- s
->buffer_offset
), n
);
439 { /* new buffer starts off empty */
443 s
->buffer_offset
= where
;
445 /* free the old buffer if necessary */
447 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
448 free_mem (s
->buffer
);
450 s
->buffer
= new_buffer
;
455 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
456 * we've already buffered the data or we need to load it. Returns
457 * NULL on I/O error. */
460 fd_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
465 where
= s
->logical_offset
;
467 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
468 where
+ *len
<= s
->buffer_offset
+ s
->active
)
471 /* Return a position within the current buffer */
473 s
->logical_offset
= where
+ *len
;
474 return s
->buffer
+ where
- s
->buffer_offset
;
477 fd_alloc (s
, where
, len
);
479 m
= where
+ s
->active
;
481 if (s
->physical_offset
!= m
&& lseek (s
->fd
, m
, SEEK_SET
) < 0)
484 /* do_read() hangs on read from terminals for *BSD-systems. Only
485 use read() in that case. */
491 n
= read (s
->fd
, s
->buffer
+ s
->active
, s
->len
- s
->active
);
495 s
->physical_offset
= where
+ n
;
502 n
= s
->len
- s
->active
;
503 if (do_read (s
, s
->buffer
+ s
->active
, &n
) != 0)
506 s
->physical_offset
= where
+ n
;
510 if (s
->active
< *len
)
511 *len
= s
->active
; /* Bytes actually available */
513 s
->logical_offset
= where
+ *len
;
519 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
520 * we've already buffered the data or we need to load it. */
523 fd_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
528 where
= s
->logical_offset
;
530 if (s
->buffer
== NULL
|| s
->buffer_offset
> where
||
531 where
+ *len
> s
->buffer_offset
+ s
->len
)
534 if (fd_flush (s
) == FAILURE
)
536 fd_alloc (s
, where
, len
);
539 /* Return a position within the current buffer */
541 || where
> s
->dirty_offset
+ s
->ndirty
542 || s
->dirty_offset
> where
+ *len
)
543 { /* Discontiguous blocks, start with a clean buffer. */
544 /* Flush the buffer. */
547 s
->dirty_offset
= where
;
552 gfc_offset start
; /* Merge with the existing data. */
553 if (where
< s
->dirty_offset
)
556 start
= s
->dirty_offset
;
557 if (where
+ *len
> s
->dirty_offset
+ s
->ndirty
)
558 s
->ndirty
= where
+ *len
- start
;
560 s
->ndirty
= s
->dirty_offset
+ s
->ndirty
- start
;
561 s
->dirty_offset
= start
;
564 s
->logical_offset
= where
+ *len
;
566 /* Don't increment file_length if the file is non-seekable. */
568 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
569 s
->file_length
= s
->logical_offset
;
571 n
= s
->logical_offset
- s
->buffer_offset
;
575 return s
->buffer
+ where
- s
->buffer_offset
;
580 fd_sfree (unix_stream
* s
)
582 if (s
->ndirty
!= 0 &&
583 (s
->buffer
!= s
->small_buffer
|| options
.all_unbuffered
||
592 fd_seek (unix_stream
* s
, gfc_offset offset
)
595 if (s
->file_length
== -1)
598 if (s
->physical_offset
== offset
) /* Are we lucky and avoid syscall? */
600 s
->logical_offset
= offset
;
604 s
->physical_offset
= s
->logical_offset
= offset
;
607 return (lseek (s
->fd
, offset
, SEEK_SET
) < 0) ? FAILURE
: SUCCESS
;
611 /* truncate_file()-- Given a unit, truncate the file at the current
612 * position. Sets the physical location to the new end of the file.
613 * Returns nonzero on error. */
616 fd_truncate (unix_stream
* s
)
618 /* Non-seekable files, like terminals and fifo's fail the lseek so just
619 return success, there is nothing to truncate. If its not a pipe there
620 is a real problem. */
621 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) == -1)
629 /* Using ftruncate on a seekable special file (like /dev/null)
630 is undefined, so we treat it as if the ftruncate succeeded. */
631 #ifdef HAVE_FTRUNCATE
632 if (s
->special_file
|| ftruncate (s
->fd
, s
->logical_offset
))
635 if (s
->special_file
|| chsize (s
->fd
, s
->logical_offset
))
639 s
->physical_offset
= s
->file_length
= 0;
643 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
649 /* Similar to memset(), but operating on a stream instead of a string.
650 Takes care of not using too much memory. */
653 fd_sset (unix_stream
* s
, int c
, size_t n
)
661 while (bytes_left
> 0)
663 /* memset() in chunks of BUFFER_SIZE. */
664 trans
= (bytes_left
< BUFFER_SIZE
) ? bytes_left
: BUFFER_SIZE
;
666 p
= fd_alloc_w_at (s
, &trans
, -1);
668 memset (p
, c
, trans
);
679 /* Stream read function. Avoids using a buffer for big reads. The
680 interface is like POSIX read(), but the nbytes argument is a
681 pointer; on return it contains the number of bytes written. The
682 function return value is the status indicator (0 for success). */
685 fd_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
690 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
693 p
= fd_alloc_r_at (s
, &tmp
, -1);
697 memcpy (buf
, p
, *nbytes
);
707 /* If the request is bigger than BUFFER_SIZE we flush the buffers
708 and read directly. */
709 if (fd_flush (s
) == FAILURE
)
715 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
721 status
= do_read (s
, buf
, nbytes
);
722 reset_stream (s
, *nbytes
);
727 /* Stream write function. Avoids using a buffer for big writes. The
728 interface is like POSIX write(), but the nbytes argument is a
729 pointer; on return it contains the number of bytes written. The
730 function return value is the status indicator (0 for success). */
733 fd_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
738 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
741 p
= fd_alloc_w_at (s
, &tmp
, -1);
745 memcpy (p
, buf
, *nbytes
);
755 /* If the request is bigger than BUFFER_SIZE we flush the buffers
756 and write directly. */
757 if (fd_flush (s
) == FAILURE
)
763 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
769 status
= do_write (s
, buf
, nbytes
);
770 reset_stream (s
, *nbytes
);
776 fd_close (unix_stream
* s
)
778 if (fd_flush (s
) == FAILURE
)
781 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
782 free_mem (s
->buffer
);
784 if (s
->fd
!= STDOUT_FILENO
&& s
->fd
!= STDERR_FILENO
)
786 if (close (s
->fd
) < 0)
797 fd_open (unix_stream
* s
)
802 s
->st
.alloc_r_at
= (void *) fd_alloc_r_at
;
803 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
804 s
->st
.sfree
= (void *) fd_sfree
;
805 s
->st
.close
= (void *) fd_close
;
806 s
->st
.seek
= (void *) fd_seek
;
807 s
->st
.truncate
= (void *) fd_truncate
;
808 s
->st
.read
= (void *) fd_read
;
809 s
->st
.write
= (void *) fd_write
;
810 s
->st
.set
= (void *) fd_sset
;
818 /*********************************************************************
819 memory stream functions - These are used for internal files
821 The idea here is that a single stream structure is created and all
822 requests must be satisfied from it. The location and size of the
823 buffer is the character variable supplied to the READ or WRITE
826 *********************************************************************/
830 mem_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
835 where
= s
->logical_offset
;
837 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
840 s
->logical_offset
= where
+ *len
;
842 n
= s
->buffer_offset
+ s
->active
- where
;
846 return s
->buffer
+ (where
- s
->buffer_offset
);
851 mem_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
855 assert (*len
>= 0); /* Negative values not allowed. */
858 where
= s
->logical_offset
;
862 if (where
< s
->buffer_offset
)
865 if (m
> s
->file_length
)
868 s
->logical_offset
= m
;
870 return s
->buffer
+ (where
- s
->buffer_offset
);
874 /* Stream read function for internal units. This is not actually used
875 at the moment, as all internal IO is formatted and the formatted IO
876 routines use mem_alloc_r_at. */
879 mem_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
885 p
= mem_alloc_r_at (s
, &tmp
, -1);
889 memcpy (buf
, p
, *nbytes
);
900 /* Stream write function for internal units. This is not actually used
901 at the moment, as all internal IO is formatted and the formatted IO
902 routines use mem_alloc_w_at. */
905 mem_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
913 p
= mem_alloc_w_at (s
, &tmp
, -1);
917 memcpy (p
, buf
, *nbytes
);
929 mem_seek (unix_stream
* s
, gfc_offset offset
)
931 if (offset
> s
->file_length
)
937 s
->logical_offset
= offset
;
943 mem_set (unix_stream
* s
, int c
, size_t n
)
950 p
= mem_alloc_w_at (s
, &len
, -1);
962 mem_truncate (unix_stream
* s
__attribute__ ((unused
)))
969 mem_close (unix_stream
* s
)
979 mem_sfree (unix_stream
* s
__attribute__ ((unused
)))
986 /*********************************************************************
987 Public functions -- A reimplementation of this module needs to
988 define functional equivalents of the following.
989 *********************************************************************/
991 /* empty_internal_buffer()-- Zero the buffer of Internal file */
994 empty_internal_buffer(stream
*strm
)
996 unix_stream
* s
= (unix_stream
*) strm
;
997 memset(s
->buffer
, ' ', s
->file_length
);
1000 /* open_internal()-- Returns a stream structure from an internal file */
1003 open_internal (char *base
, int length
)
1007 s
= get_mem (sizeof (unix_stream
));
1008 memset (s
, '\0', sizeof (unix_stream
));
1011 s
->buffer_offset
= 0;
1013 s
->logical_offset
= 0;
1014 s
->active
= s
->file_length
= length
;
1016 s
->st
.alloc_r_at
= (void *) mem_alloc_r_at
;
1017 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
1018 s
->st
.sfree
= (void *) mem_sfree
;
1019 s
->st
.close
= (void *) mem_close
;
1020 s
->st
.seek
= (void *) mem_seek
;
1021 s
->st
.truncate
= (void *) mem_truncate
;
1022 s
->st
.read
= (void *) mem_read
;
1023 s
->st
.write
= (void *) mem_write
;
1024 s
->st
.set
= (void *) mem_set
;
1026 return (stream
*) s
;
1030 /* fd_to_stream()-- Given an open file descriptor, build a stream
1034 fd_to_stream (int fd
, int prot
)
1036 struct stat statbuf
;
1039 s
= get_mem (sizeof (unix_stream
));
1040 memset (s
, '\0', sizeof (unix_stream
));
1043 s
->buffer_offset
= 0;
1044 s
->physical_offset
= 0;
1045 s
->logical_offset
= 0;
1048 /* Get the current length of the file. */
1050 fstat (fd
, &statbuf
);
1052 if (lseek (fd
, 0, SEEK_CUR
) == (off_t
) -1)
1053 s
->file_length
= -1;
1055 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
1057 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
1061 return (stream
*) s
;
1065 /* Given the Fortran unit number, convert it to a C file descriptor. */
1068 unit_to_fd (int unit
)
1073 us
= find_unit (unit
);
1077 fd
= ((unix_stream
*) us
->s
)->fd
;
1083 /* unpack_filename()-- Given a fortran string and a pointer to a
1084 * buffer that is PATH_MAX characters, convert the fortran string to a
1085 * C string in the buffer. Returns nonzero if this is not possible. */
1088 unpack_filename (char *cstring
, const char *fstring
, int len
)
1090 len
= fstrlen (fstring
, len
);
1091 if (len
>= PATH_MAX
)
1094 memmove (cstring
, fstring
, len
);
1095 cstring
[len
] = '\0';
1101 /* tempfile()-- Generate a temporary filename for a scratch file and
1102 * open it. mkstemp() opens the file for reading and writing, but the
1103 * library mode prevents anything that is not allowed. The descriptor
1104 * is returned, which is -1 on error. The template is pointed to by
1105 * opp->file, which is copied into the unit structure
1106 * and freed later. */
1109 tempfile (st_parameter_open
*opp
)
1111 const char *tempdir
;
1115 tempdir
= getenv ("GFORTRAN_TMPDIR");
1116 if (tempdir
== NULL
)
1117 tempdir
= getenv ("TMP");
1118 if (tempdir
== NULL
)
1119 tempdir
= getenv ("TEMP");
1120 if (tempdir
== NULL
)
1121 tempdir
= DEFAULT_TEMPDIR
;
1123 template = get_mem (strlen (tempdir
) + 20);
1125 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
1129 fd
= mkstemp (template);
1131 #else /* HAVE_MKSTEMP */
1133 if (mktemp (template))
1135 #if defined(HAVE_CRLF) && defined(O_BINARY)
1136 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1137 S_IREAD
| S_IWRITE
);
1139 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1141 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
1145 #endif /* HAVE_MKSTEMP */
1148 free_mem (template);
1151 opp
->file
= template;
1152 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1159 /* regular_file()-- Open a regular file.
1160 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1161 * unless an error occurs.
1162 * Returns the descriptor, which is less than zero on error. */
1165 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1167 char path
[PATH_MAX
+ 1];
1173 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1175 errno
= ENOENT
; /* Fake an OS error */
1181 switch (flags
->action
)
1191 case ACTION_READWRITE
:
1192 case ACTION_UNSPECIFIED
:
1197 internal_error (&opp
->common
, "regular_file(): Bad action");
1200 switch (flags
->status
)
1203 crflag
= O_CREAT
| O_EXCL
;
1206 case STATUS_OLD
: /* open will fail if the file does not exist*/
1210 case STATUS_UNKNOWN
:
1211 case STATUS_SCRATCH
:
1215 case STATUS_REPLACE
:
1216 crflag
= O_CREAT
| O_TRUNC
;
1220 internal_error (&opp
->common
, "regular_file(): Bad status");
1223 /* rwflag |= O_LARGEFILE; */
1225 #if defined(HAVE_CRLF) && defined(O_BINARY)
1229 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1230 fd
= open (path
, rwflag
| crflag
, mode
);
1231 if (flags
->action
!= ACTION_UNSPECIFIED
)
1236 flags
->action
= ACTION_READWRITE
;
1239 if (errno
!= EACCES
&& errno
!= EROFS
)
1242 /* retry for read-only access */
1244 fd
= open (path
, rwflag
| crflag
, mode
);
1247 flags
->action
= ACTION_READ
;
1248 return fd
; /* success */
1251 if (errno
!= EACCES
)
1252 return fd
; /* failure */
1254 /* retry for write-only access */
1256 fd
= open (path
, rwflag
| crflag
, mode
);
1259 flags
->action
= ACTION_WRITE
;
1260 return fd
; /* success */
1262 return fd
; /* failure */
1266 /* open_external()-- Open an external file, unix specific version.
1267 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1268 * Returns NULL on operating system error. */
1271 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1275 if (flags
->status
== STATUS_SCRATCH
)
1277 fd
= tempfile (opp
);
1278 if (flags
->action
== ACTION_UNSPECIFIED
)
1279 flags
->action
= ACTION_READWRITE
;
1281 #if HAVE_UNLINK_OPEN_FILE
1282 /* We can unlink scratch files now and it will go away when closed. */
1289 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1291 fd
= regular_file (opp
, flags
);
1298 switch (flags
->action
)
1308 case ACTION_READWRITE
:
1309 prot
= PROT_READ
| PROT_WRITE
;
1313 internal_error (&opp
->common
, "open_external(): Bad action");
1316 return fd_to_stream (fd
, prot
);
1320 /* input_stream()-- Return a stream pointer to the default input stream.
1321 * Called on initialization. */
1326 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1330 /* output_stream()-- Return a stream pointer to the default output stream.
1331 * Called on initialization. */
1334 output_stream (void)
1336 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1337 setmode (STDOUT_FILENO
, O_BINARY
);
1339 return fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1343 /* error_stream()-- Return a stream pointer to the default error stream.
1344 * Called on initialization. */
1349 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1350 setmode (STDERR_FILENO
, O_BINARY
);
1352 return fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1355 /* init_error_stream()-- Return a pointer to the error stream. This
1356 * subroutine is called when the stream is needed, rather than at
1357 * initialization. We want to work even if memory has been seriously
1361 init_error_stream (unix_stream
*error
)
1363 memset (error
, '\0', sizeof (*error
));
1365 error
->fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1367 error
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
1368 error
->st
.sfree
= (void *) fd_sfree
;
1370 error
->unbuffered
= 1;
1371 error
->buffer
= error
->small_buffer
;
1373 return (stream
*) error
;
1376 /* st_printf()-- simple printf() function for streams that handles the
1377 * formats %d, %s and %c. This function handles printing of error
1378 * messages that originate within the library itself, not from a user
1382 st_printf (const char *format
, ...)
1389 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1390 unix_stream err_stream
;
1393 s
= init_error_stream (&err_stream
);
1394 va_start (arg
, format
);
1400 while (format
[count
] != '%' && format
[count
] != '\0')
1405 p
= salloc_w (s
, &count
);
1406 memmove (p
, format
, count
);
1412 if (*format
++ == '\0')
1420 p
= salloc_w (s
, &count
);
1421 *p
= (char) va_arg (arg
, int);
1427 q
= gfc_itoa (va_arg (arg
, int), itoa_buf
, sizeof (itoa_buf
));
1430 p
= salloc_w (s
, &count
);
1431 memmove (p
, q
, count
);
1436 q
= xtoa (va_arg (arg
, unsigned), itoa_buf
, sizeof (itoa_buf
));
1439 p
= salloc_w (s
, &count
);
1440 memmove (p
, q
, count
);
1445 q
= va_arg (arg
, char *);
1448 p
= salloc_w (s
, &count
);
1449 memmove (p
, q
, count
);
1458 p
= salloc_w (s
, &count
);
1474 /* compare_file_filename()-- Given an open stream and a fortran string
1475 * that is a filename, figure out if the file is the same as the
1479 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1481 char path
[PATH_MAX
+ 1];
1483 #ifdef HAVE_WORKING_STAT
1487 if (unpack_filename (path
, name
, len
))
1488 return 0; /* Can't be the same */
1490 /* If the filename doesn't exist, then there is no match with the
1493 if (stat (path
, &st1
) < 0)
1496 #ifdef HAVE_WORKING_STAT
1497 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1498 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1500 if (len
!= u
->file_len
)
1502 return (memcmp(path
, u
->file
, len
) == 0);
1507 #ifdef HAVE_WORKING_STAT
1508 # define FIND_FILE0_DECL struct stat *st
1509 # define FIND_FILE0_ARGS st
1511 # define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
1512 # define FIND_FILE0_ARGS file, file_len
1515 /* find_file0()-- Recursive work function for find_file() */
1518 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1525 #ifdef HAVE_WORKING_STAT
1527 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1528 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1531 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1535 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1539 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1547 /* find_file()-- Take the current filename and see if there is a unit
1548 * that has the file already open. Returns a pointer to the unit if so. */
1551 find_file (const char *file
, gfc_charlen_type file_len
)
1553 char path
[PATH_MAX
+ 1];
1557 if (unpack_filename (path
, file
, file_len
))
1560 if (stat (path
, &st
[0]) < 0)
1563 __gthread_mutex_lock (&unit_lock
);
1565 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1569 if (! __gthread_mutex_trylock (&u
->lock
))
1571 /* assert (u->closed == 0); */
1572 __gthread_mutex_unlock (&unit_lock
);
1576 inc_waiting_locked (u
);
1578 __gthread_mutex_unlock (&unit_lock
);
1581 __gthread_mutex_lock (&u
->lock
);
1584 __gthread_mutex_lock (&unit_lock
);
1585 __gthread_mutex_unlock (&u
->lock
);
1586 if (predec_waiting_locked (u
) == 0)
1591 dec_waiting_unlocked (u
);
1597 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1601 if (u
->unit_number
> min_unit
)
1603 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1607 if (u
->unit_number
>= min_unit
)
1609 if (__gthread_mutex_trylock (&u
->lock
))
1613 __gthread_mutex_unlock (&u
->lock
);
1621 flush_all_units (void)
1626 __gthread_mutex_lock (&unit_lock
);
1629 u
= flush_all_units_1 (unit_root
, min_unit
);
1631 inc_waiting_locked (u
);
1632 __gthread_mutex_unlock (&unit_lock
);
1636 __gthread_mutex_lock (&u
->lock
);
1638 min_unit
= u
->unit_number
+ 1;
1643 __gthread_mutex_lock (&unit_lock
);
1644 __gthread_mutex_unlock (&u
->lock
);
1645 (void) predec_waiting_locked (u
);
1649 __gthread_mutex_lock (&unit_lock
);
1650 __gthread_mutex_unlock (&u
->lock
);
1651 if (predec_waiting_locked (u
) == 0)
1659 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1663 stream_at_bof (stream
* s
)
1667 if (!is_seekable (s
))
1670 us
= (unix_stream
*) s
;
1672 return us
->logical_offset
== 0;
1676 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1680 stream_at_eof (stream
* s
)
1684 if (!is_seekable (s
))
1687 us
= (unix_stream
*) s
;
1689 return us
->logical_offset
== us
->dirty_offset
;
1693 /* delete_file()-- Given a unit structure, delete the file associated
1694 * with the unit. Returns nonzero if something went wrong. */
1697 delete_file (gfc_unit
* u
)
1699 char path
[PATH_MAX
+ 1];
1701 if (unpack_filename (path
, u
->file
, u
->file_len
))
1702 { /* Shouldn't be possible */
1707 return unlink (path
);
1711 /* file_exists()-- Returns nonzero if the current filename exists on
1715 file_exists (const char *file
, gfc_charlen_type file_len
)
1717 char path
[PATH_MAX
+ 1];
1718 struct stat statbuf
;
1720 if (unpack_filename (path
, file
, file_len
))
1723 if (stat (path
, &statbuf
) < 0)
1731 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1733 /* inquire_sequential()-- Given a fortran string, determine if the
1734 * file is suitable for sequential access. Returns a C-style
1738 inquire_sequential (const char *string
, int len
)
1740 char path
[PATH_MAX
+ 1];
1741 struct stat statbuf
;
1743 if (string
== NULL
||
1744 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1747 if (S_ISREG (statbuf
.st_mode
) ||
1748 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1751 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1758 /* inquire_direct()-- Given a fortran string, determine if the file is
1759 * suitable for direct access. Returns a C-style string. */
1762 inquire_direct (const char *string
, int len
)
1764 char path
[PATH_MAX
+ 1];
1765 struct stat statbuf
;
1767 if (string
== NULL
||
1768 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1771 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1774 if (S_ISDIR (statbuf
.st_mode
) ||
1775 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1782 /* inquire_formatted()-- Given a fortran string, determine if the file
1783 * is suitable for formatted form. Returns a C-style string. */
1786 inquire_formatted (const char *string
, int len
)
1788 char path
[PATH_MAX
+ 1];
1789 struct stat statbuf
;
1791 if (string
== NULL
||
1792 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1795 if (S_ISREG (statbuf
.st_mode
) ||
1796 S_ISBLK (statbuf
.st_mode
) ||
1797 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1800 if (S_ISDIR (statbuf
.st_mode
))
1807 /* inquire_unformatted()-- Given a fortran string, determine if the file
1808 * is suitable for unformatted form. Returns a C-style string. */
1811 inquire_unformatted (const char *string
, int len
)
1813 return inquire_formatted (string
, len
);
1817 /* inquire_access()-- Given a fortran string, determine if the file is
1818 * suitable for access. */
1821 inquire_access (const char *string
, int len
, int mode
)
1823 char path
[PATH_MAX
+ 1];
1825 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1826 access (path
, mode
) < 0)
1833 /* inquire_read()-- Given a fortran string, determine if the file is
1834 * suitable for READ access. */
1837 inquire_read (const char *string
, int len
)
1839 return inquire_access (string
, len
, R_OK
);
1843 /* inquire_write()-- Given a fortran string, determine if the file is
1844 * suitable for READ access. */
1847 inquire_write (const char *string
, int len
)
1849 return inquire_access (string
, len
, W_OK
);
1853 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1854 * suitable for read and write access. */
1857 inquire_readwrite (const char *string
, int len
)
1859 return inquire_access (string
, len
, R_OK
| W_OK
);
1863 /* file_length()-- Return the file length in bytes, -1 if unknown */
1866 file_length (stream
* s
)
1868 return ((unix_stream
*) s
)->file_length
;
1872 /* file_position()-- Return the current position of the file */
1875 file_position (stream
*s
)
1877 return ((unix_stream
*) s
)->logical_offset
;
1881 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1885 is_seekable (stream
*s
)
1887 /* By convention, if file_length == -1, the file is not
1889 return ((unix_stream
*) s
)->file_length
!=-1;
1893 /* is_special()-- Return nonzero if the stream is not a regular file. */
1896 is_special (stream
*s
)
1898 return ((unix_stream
*) s
)->special_file
;
1905 return fd_flush( (unix_stream
*) s
);
1909 stream_isatty (stream
*s
)
1911 return isatty (((unix_stream
*) s
)->fd
);
1915 stream_ttyname (stream
*s
)
1918 return ttyname (((unix_stream
*) s
)->fd
);
1925 stream_offset (stream
*s
)
1927 return (((unix_stream
*) s
)->logical_offset
);
1931 /* How files are stored: This is an operating-system specific issue,
1932 and therefore belongs here. There are three cases to consider.
1935 Records are written as block of bytes corresponding to the record
1936 length of the file. This goes for both formatted and unformatted
1937 records. Positioning is done explicitly for each data transfer,
1938 so positioning is not much of an issue.
1940 Sequential Formatted:
1941 Records are separated by newline characters. The newline character
1942 is prohibited from appearing in a string. If it does, this will be
1943 messed up on the next read. End of file is also the end of a record.
1945 Sequential Unformatted:
1946 In this case, we are merely copying bytes to and from main storage,
1947 yet we need to keep track of varying record lengths. We adopt
1948 the solution used by f2c. Each record contains a pair of length
1951 Length of record n in bytes
1953 Length of record n in bytes
1955 Length of record n+1 in bytes
1957 Length of record n+1 in bytes
1959 The length is stored at the end of a record to allow backspacing to the
1960 previous record. Between data transfer statements, the file pointer
1961 is left pointing to the first length of the current record.
1963 ENDFILE records are never explicitly stored.