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. */
100 int len; /* Physical length of the current buffer */
101 int active; /* Length of valid bytes in the buffer */
104 int ndirty; /* Dirty bytes starting at dirty_offset */
106 int special_file; /* =1 if the fd refers to a special file */
108 int unbuffered; /* =1 if the stream is not buffered */
110 char buffer[BUFFER_SIZE];
115 /* Stream structure for internal files. Fields must be kept in sync
116 with unix_stream above, except for the buffer. For internal files
117 we point the buffer pointer directly at the destination memory. */
124 gfc_offset buffer_offset; /* File offset of the start of the buffer */
125 gfc_offset physical_offset; /* Current physical file offset */
126 gfc_offset logical_offset; /* Current logical file offset */
127 gfc_offset dirty_offset; /* Start of modified bytes in buffer */
128 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
130 int len; /* Physical length of the current buffer */
131 int active; /* Length of valid bytes in the buffer */
134 int ndirty; /* Dirty bytes starting at dirty_offset */
136 int special_file; /* =1 if the fd refers to a special file */
138 int unbuffered; /* =1 if the stream is not buffered */
144 extern stream *init_error_stream (unix_stream *);
145 internal_proto(init_error_stream);
148 /* This implementation of stream I/O is based on the paper:
150 * "Exploiting the advantages of mapped files for stream I/O",
151 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
152 * USENIX conference", p. 27-42.
154 * It differs in a number of ways from the version described in the
155 * paper. First of all, threads are not an issue during I/O and we
156 * also don't have to worry about having multiple regions, since
157 * fortran's I/O model only allows you to be one place at a time.
159 * On the other hand, we have to be able to writing at the end of a
160 * stream, read from the start of a stream or read and write blocks of
161 * bytes from an arbitrary position. After opening a file, a pointer
162 * to a stream structure is returned, which is used to handle file
163 * accesses until the file is closed.
165 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
166 * pointer to a block of memory that mirror the file at position
167 * 'where' that is 'len' bytes long. The len integer is updated to
168 * reflect how many bytes were actually read. The only reason for a
169 * short read is end of file. The file pointer is updated. The
170 * pointer is valid until the next call to salloc_*.
172 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
173 * a pointer to a block of memory that is updated to reflect the state
174 * of the file. The length of the buffer is always equal to that
175 * requested. The buffer must be completely set by the caller. When
176 * data has been written, the sfree() function must be called to
177 * indicate that the caller is done writing data to the buffer. This
178 * may or may not cause a physical write.
180 * Short forms of these are salloc_r() and salloc_w() which drop the
181 * 'where' parameter and use the current file pointer. */
184 /*move_pos_offset()-- Move the record pointer right or left
185 *relative to current position */
188 move_pos_offset (stream* st, int pos_off)
190 unix_stream * str = (unix_stream*)st;
193 str->logical_offset += pos_off;
195 if (str->dirty_offset + str->ndirty > str->logical_offset)
197 if (str->ndirty + pos_off > 0)
198 str->ndirty += pos_off;
201 str->dirty_offset += pos_off + pos_off;
212 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
213 * standard descriptors, returning a non-standard descriptor. If the
214 * user specifies that system errors should go to standard output,
215 * then closes standard output, we don't want the system errors to a
216 * file that has been given file descriptor 1 or 0. We want to send
217 * the error to the invalid descriptor. */
222 int input, output, error;
224 input = output = error = 0;
226 /* Unix allocates the lowest descriptors first, so a loop is not
227 required, but this order is. */
229 if (fd == STDIN_FILENO)
234 if (fd == STDOUT_FILENO)
239 if (fd == STDERR_FILENO)
246 close (STDIN_FILENO);
248 close (STDOUT_FILENO);
250 close (STDERR_FILENO);
256 is_preconnected (stream * s)
260 fd = ((unix_stream *) s)->fd;
261 if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO)
267 /* If the stream corresponds to a preconnected unit, we flush the
268 corresponding C stream. This is bugware for mixed C-Fortran codes
269 where the C code doesn't flush I/O before returning. */
271 flush_if_preconnected (stream * s)
275 fd = ((unix_stream *) s)->fd;
276 if (fd == STDIN_FILENO)
278 else if (fd == STDOUT_FILENO)
280 else if (fd == STDERR_FILENO)
285 /* Reset a stream after reading/writing. Assumes that the buffers have
289 reset_stream (unix_stream * s, size_t bytes_rw)
291 s->physical_offset += bytes_rw;
292 s->logical_offset = s->physical_offset;
293 if (s->file_length != -1 && s->physical_offset > s->file_length)
294 s->file_length = s->physical_offset;
298 /* Read bytes into a buffer, allowing for short reads. If the nbytes
299 * argument is less on return than on entry, it is because we've hit
300 * the end of file. */
303 do_read (unix_stream * s, void * buf, size_t * nbytes)
311 bytes_left = *nbytes;
312 buf_st = (char *) buf;
314 /* We must read in a loop since some systems don't restart system
315 calls in case of a signal. */
316 while (bytes_left > 0)
318 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
319 so we must read in chunks smaller than SSIZE_MAX. */
320 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
321 trans = read (s->fd, buf_st, trans);
332 else if (trans == 0) /* We hit EOF. */
338 *nbytes -= bytes_left;
343 /* Write a buffer to a stream, allowing for short writes. */
346 do_write (unix_stream * s, const void * buf, size_t * nbytes)
354 bytes_left = *nbytes;
355 buf_st = (char *) buf;
357 /* We must write in a loop since some systems don't restart system
358 calls in case of a signal. */
359 while (bytes_left > 0)
361 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
362 so we must write in chunks smaller than SSIZE_MAX. */
363 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
364 trans = write (s->fd, buf_st, trans);
379 *nbytes -= bytes_left;
384 /* get_oserror()-- Get the most recent operating system error. For
385 * unix, this is errno. */
390 return strerror (errno);
394 /*********************************************************************
395 File descriptor stream functions
396 *********************************************************************/
399 /* fd_flush()-- Write bytes that need to be written */
402 fd_flush (unix_stream * s)
409 if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
410 lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
413 writelen = s->ndirty;
414 if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
418 s->physical_offset = s->dirty_offset + writelen;
420 /* don't increment file_length if the file is non-seekable */
421 if (s->file_length != -1 && s->physical_offset > s->file_length)
422 s->file_length = s->physical_offset;
424 s->ndirty -= writelen;
432 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
433 * satisfied. This subroutine gets the buffer ready for whatever is
437 fd_alloc (unix_stream * s, gfc_offset where,
438 int *len __attribute__ ((unused)))
442 /* Salvage bytes currently within the buffer. This is important for
443 * devices that cannot seek. */
445 if (s->buffer_offset <= where &&
446 where <= s->buffer_offset + s->active)
449 n = s->active - (where - s->buffer_offset);
450 memmove (s->buffer, s->buffer + (where - s->buffer_offset), n);
455 { /* new buffer starts off empty */
459 s->buffer_offset = where;
461 s->len = BUFFER_SIZE;
465 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
466 * we've already buffered the data or we need to load it. Returns
467 * NULL on I/O error. */
470 fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
475 where = s->logical_offset;
477 if (s->buffer != NULL && s->buffer_offset <= where &&
478 where + *len <= s->buffer_offset + s->active)
481 /* Return a position within the current buffer */
483 s->logical_offset = where + *len;
484 return s->buffer + where - s->buffer_offset;
487 fd_alloc (s, where, len);
489 m = where + s->active;
491 if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
494 /* do_read() hangs on read from terminals for *BSD-systems. Only
495 use read() in that case. */
501 n = read (s->fd, s->buffer + s->active, s->len - s->active);
505 s->physical_offset = m + n;
512 n = s->len - s->active;
513 if (do_read (s, s->buffer + s->active, &n) != 0)
516 s->physical_offset = m + n;
520 if (s->active < *len)
521 *len = s->active; /* Bytes actually available */
523 s->logical_offset = where + *len;
529 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
530 * we've already buffered the data or we need to load it. */
533 fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
538 where = s->logical_offset;
540 if (s->buffer == NULL || s->buffer_offset > where ||
541 where + *len > s->buffer_offset + s->len)
544 if (fd_flush (s) == FAILURE)
546 fd_alloc (s, where, len);
549 /* Return a position within the current buffer */
551 || where > s->dirty_offset + s->ndirty
552 || s->dirty_offset > where + *len)
553 { /* Discontiguous blocks, start with a clean buffer. */
554 /* Flush the buffer. */
557 s->dirty_offset = where;
562 gfc_offset start; /* Merge with the existing data. */
563 if (where < s->dirty_offset)
566 start = s->dirty_offset;
567 if (where + *len > s->dirty_offset + s->ndirty)
568 s->ndirty = where + *len - start;
570 s->ndirty = s->dirty_offset + s->ndirty - start;
571 s->dirty_offset = start;
574 s->logical_offset = where + *len;
576 /* Don't increment file_length if the file is non-seekable. */
578 if (s->file_length != -1 && s->logical_offset > s->file_length)
579 s->file_length = s->logical_offset;
581 n = s->logical_offset - s->buffer_offset;
585 return s->buffer + where - s->buffer_offset;
590 fd_sfree (unix_stream * s)
592 if (s->ndirty != 0 &&
593 (options.all_unbuffered || s->unbuffered))
601 fd_seek (unix_stream * s, gfc_offset offset)
604 if (s->file_length == -1)
607 if (s->physical_offset == offset) /* Are we lucky and avoid syscall? */
609 s->logical_offset = offset;
613 if (lseek (s->fd, offset, SEEK_SET) >= 0)
615 s->physical_offset = s->logical_offset = offset;
624 /* truncate_file()-- Given a unit, truncate the file at the current
625 * position. Sets the physical location to the new end of the file.
626 * Returns nonzero on error. */
629 fd_truncate (unix_stream * s)
631 /* Non-seekable files, like terminals and fifo's fail the lseek so just
632 return success, there is nothing to truncate. If its not a pipe there
633 is a real problem. */
634 if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
642 /* Using ftruncate on a seekable special file (like /dev/null)
643 is undefined, so we treat it as if the ftruncate succeeded. */
644 #ifdef HAVE_FTRUNCATE
645 if (s->special_file || ftruncate (s->fd, s->logical_offset))
648 if (s->special_file || chsize (s->fd, s->logical_offset))
652 s->physical_offset = s->file_length = 0;
656 s->physical_offset = s->file_length = s->logical_offset;
662 /* Similar to memset(), but operating on a stream instead of a string.
663 Takes care of not using too much memory. */
666 fd_sset (unix_stream * s, int c, size_t n)
674 while (bytes_left > 0)
676 /* memset() in chunks of BUFFER_SIZE. */
677 trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
679 p = fd_alloc_w_at (s, &trans, -1);
681 memset (p, c, trans);
692 /* Stream read function. Avoids using a buffer for big reads. The
693 interface is like POSIX read(), but the nbytes argument is a
694 pointer; on return it contains the number of bytes written. The
695 function return value is the status indicator (0 for success). */
698 fd_read (unix_stream * s, void * buf, size_t * nbytes)
703 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
706 p = fd_alloc_r_at (s, &tmp, -1);
710 memcpy (buf, p, *nbytes);
720 /* If the request is bigger than BUFFER_SIZE we flush the buffers
721 and read directly. */
722 if (fd_flush (s) == FAILURE)
728 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
734 status = do_read (s, buf, nbytes);
735 reset_stream (s, *nbytes);
740 /* Stream write function. Avoids using a buffer for big writes. The
741 interface is like POSIX write(), but the nbytes argument is a
742 pointer; on return it contains the number of bytes written. The
743 function return value is the status indicator (0 for success). */
746 fd_write (unix_stream * s, const void * buf, size_t * nbytes)
751 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
754 p = fd_alloc_w_at (s, &tmp, -1);
758 memcpy (p, buf, *nbytes);
768 /* If the request is bigger than BUFFER_SIZE we flush the buffers
769 and write directly. */
770 if (fd_flush (s) == FAILURE)
776 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
782 status = do_write (s, buf, nbytes);
783 reset_stream (s, *nbytes);
789 fd_close (unix_stream * s)
791 if (fd_flush (s) == FAILURE)
794 if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO)
796 if (close (s->fd) < 0)
807 fd_open (unix_stream * s)
812 s->st.alloc_r_at = (void *) fd_alloc_r_at;
813 s->st.alloc_w_at = (void *) fd_alloc_w_at;
814 s->st.sfree = (void *) fd_sfree;
815 s->st.close = (void *) fd_close;
816 s->st.seek = (void *) fd_seek;
817 s->st.truncate = (void *) fd_truncate;
818 s->st.read = (void *) fd_read;
819 s->st.write = (void *) fd_write;
820 s->st.set = (void *) fd_sset;
827 /*********************************************************************
828 memory stream functions - These are used for internal files
830 The idea here is that a single stream structure is created and all
831 requests must be satisfied from it. The location and size of the
832 buffer is the character variable supplied to the READ or WRITE
835 *********************************************************************/
839 mem_alloc_r_at (int_stream * s, int *len, gfc_offset where)
844 where = s->logical_offset;
846 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
849 s->logical_offset = where + *len;
851 n = s->buffer_offset + s->active - where;
855 return s->buffer + (where - s->buffer_offset);
860 mem_alloc_w_at (int_stream * s, int *len, gfc_offset where)
864 assert (*len >= 0); /* Negative values not allowed. */
867 where = s->logical_offset;
871 if (where < s->buffer_offset)
874 if (m > s->file_length)
877 s->logical_offset = m;
879 return s->buffer + (where - s->buffer_offset);
883 /* Stream read function for internal units. This is not actually used
884 at the moment, as all internal IO is formatted and the formatted IO
885 routines use mem_alloc_r_at. */
888 mem_read (int_stream * s, void * buf, size_t * nbytes)
894 p = mem_alloc_r_at (s, &tmp, -1);
898 memcpy (buf, p, *nbytes);
909 /* Stream write function for internal units. This is not actually used
910 at the moment, as all internal IO is formatted and the formatted IO
911 routines use mem_alloc_w_at. */
914 mem_write (int_stream * s, const void * buf, size_t * nbytes)
922 p = mem_alloc_w_at (s, &tmp, -1);
926 memcpy (p, buf, *nbytes);
938 mem_seek (int_stream * s, gfc_offset offset)
940 if (offset > s->file_length)
946 s->logical_offset = offset;
952 mem_set (int_stream * s, int c, size_t n)
959 p = mem_alloc_w_at (s, &len, -1);
971 mem_truncate (int_stream * s __attribute__ ((unused)))
978 mem_close (int_stream * s)
988 mem_sfree (int_stream * s __attribute__ ((unused)))
995 /*********************************************************************
996 Public functions -- A reimplementation of this module needs to
997 define functional equivalents of the following.
998 *********************************************************************/
1000 /* empty_internal_buffer()-- Zero the buffer of Internal file */
1003 empty_internal_buffer(stream *strm)
1005 int_stream * s = (int_stream *) strm;
1006 memset(s->buffer, ' ', s->file_length);
1009 /* open_internal()-- Returns a stream structure from an internal file */
1012 open_internal (char *base, int length)
1016 s = get_mem (sizeof (int_stream));
1017 memset (s, '\0', sizeof (int_stream));
1020 s->buffer_offset = 0;
1022 s->logical_offset = 0;
1023 s->active = s->file_length = length;
1025 s->st.alloc_r_at = (void *) mem_alloc_r_at;
1026 s->st.alloc_w_at = (void *) mem_alloc_w_at;
1027 s->st.sfree = (void *) mem_sfree;
1028 s->st.close = (void *) mem_close;
1029 s->st.seek = (void *) mem_seek;
1030 s->st.truncate = (void *) mem_truncate;
1031 s->st.read = (void *) mem_read;
1032 s->st.write = (void *) mem_write;
1033 s->st.set = (void *) mem_set;
1035 return (stream *) s;
1039 /* fd_to_stream()-- Given an open file descriptor, build a stream
1043 fd_to_stream (int fd, int prot)
1045 struct stat statbuf;
1048 s = get_mem (sizeof (unix_stream));
1049 memset (s, '\0', sizeof (unix_stream));
1052 s->buffer_offset = 0;
1053 s->physical_offset = 0;
1054 s->logical_offset = 0;
1057 /* Get the current length of the file. */
1059 fstat (fd, &statbuf);
1061 if (lseek (fd, 0, SEEK_CUR) == (off_t) -1)
1062 s->file_length = -1;
1064 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
1066 s->special_file = !S_ISREG (statbuf.st_mode);
1070 return (stream *) s;
1074 /* Given the Fortran unit number, convert it to a C file descriptor. */
1077 unit_to_fd (int unit)
1082 us = find_unit (unit);
1086 fd = ((unix_stream *) us->s)->fd;
1092 /* unpack_filename()-- Given a fortran string and a pointer to a
1093 * buffer that is PATH_MAX characters, convert the fortran string to a
1094 * C string in the buffer. Returns nonzero if this is not possible. */
1097 unpack_filename (char *cstring, const char *fstring, int len)
1099 len = fstrlen (fstring, len);
1100 if (len >= PATH_MAX)
1103 memmove (cstring, fstring, len);
1104 cstring[len] = '\0';
1110 /* tempfile()-- Generate a temporary filename for a scratch file and
1111 * open it. mkstemp() opens the file for reading and writing, but the
1112 * library mode prevents anything that is not allowed. The descriptor
1113 * is returned, which is -1 on error. The template is pointed to by
1114 * opp->file, which is copied into the unit structure
1115 * and freed later. */
1118 tempfile (st_parameter_open *opp)
1120 const char *tempdir;
1124 tempdir = getenv ("GFORTRAN_TMPDIR");
1125 if (tempdir == NULL)
1126 tempdir = getenv ("TMP");
1127 if (tempdir == NULL)
1128 tempdir = getenv ("TEMP");
1129 if (tempdir == NULL)
1130 tempdir = DEFAULT_TEMPDIR;
1132 template = get_mem (strlen (tempdir) + 20);
1134 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
1138 fd = mkstemp (template);
1140 #else /* HAVE_MKSTEMP */
1142 if (mktemp (template))
1144 #if defined(HAVE_CRLF) && defined(O_BINARY)
1145 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1146 S_IREAD | S_IWRITE);
1148 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1150 while (!(fd == -1 && errno == EEXIST) && mktemp (template));
1154 #endif /* HAVE_MKSTEMP */
1157 free_mem (template);
1160 opp->file = template;
1161 opp->file_len = strlen (template); /* Don't include trailing nul */
1168 /* regular_file()-- Open a regular file.
1169 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1170 * unless an error occurs.
1171 * Returns the descriptor, which is less than zero on error. */
1174 regular_file (st_parameter_open *opp, unit_flags *flags)
1176 char path[PATH_MAX + 1];
1182 if (unpack_filename (path, opp->file, opp->file_len))
1184 errno = ENOENT; /* Fake an OS error */
1190 switch (flags->action)
1200 case ACTION_READWRITE:
1201 case ACTION_UNSPECIFIED:
1206 internal_error (&opp->common, "regular_file(): Bad action");
1209 switch (flags->status)
1212 crflag = O_CREAT | O_EXCL;
1215 case STATUS_OLD: /* open will fail if the file does not exist*/
1219 case STATUS_UNKNOWN:
1220 case STATUS_SCRATCH:
1224 case STATUS_REPLACE:
1225 crflag = O_CREAT | O_TRUNC;
1229 internal_error (&opp->common, "regular_file(): Bad status");
1232 /* rwflag |= O_LARGEFILE; */
1234 #if defined(HAVE_CRLF) && defined(O_BINARY)
1238 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1239 fd = open (path, rwflag | crflag, mode);
1240 if (flags->action != ACTION_UNSPECIFIED)
1245 flags->action = ACTION_READWRITE;
1248 if (errno != EACCES && errno != EROFS)
1251 /* retry for read-only access */
1253 fd = open (path, rwflag | crflag, mode);
1256 flags->action = ACTION_READ;
1257 return fd; /* success */
1260 if (errno != EACCES)
1261 return fd; /* failure */
1263 /* retry for write-only access */
1265 fd = open (path, rwflag | crflag, mode);
1268 flags->action = ACTION_WRITE;
1269 return fd; /* success */
1271 return fd; /* failure */
1275 /* open_external()-- Open an external file, unix specific version.
1276 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1277 * Returns NULL on operating system error. */
1280 open_external (st_parameter_open *opp, unit_flags *flags)
1284 if (flags->status == STATUS_SCRATCH)
1286 fd = tempfile (opp);
1287 if (flags->action == ACTION_UNSPECIFIED)
1288 flags->action = ACTION_READWRITE;
1290 #if HAVE_UNLINK_OPEN_FILE
1291 /* We can unlink scratch files now and it will go away when closed. */
1298 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1300 fd = regular_file (opp, flags);
1307 switch (flags->action)
1317 case ACTION_READWRITE:
1318 prot = PROT_READ | PROT_WRITE;
1322 internal_error (&opp->common, "open_external(): Bad action");
1325 return fd_to_stream (fd, prot);
1329 /* input_stream()-- Return a stream pointer to the default input stream.
1330 * Called on initialization. */
1335 return fd_to_stream (STDIN_FILENO, PROT_READ);
1339 /* output_stream()-- Return a stream pointer to the default output stream.
1340 * Called on initialization. */
1343 output_stream (void)
1345 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1346 setmode (STDOUT_FILENO, O_BINARY);
1348 return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1352 /* error_stream()-- Return a stream pointer to the default error stream.
1353 * Called on initialization. */
1358 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1359 setmode (STDERR_FILENO, O_BINARY);
1361 return fd_to_stream (STDERR_FILENO, PROT_WRITE);
1364 /* init_error_stream()-- Return a pointer to the error stream. This
1365 * subroutine is called when the stream is needed, rather than at
1366 * initialization. We want to work even if memory has been seriously
1370 init_error_stream (unix_stream *error)
1372 memset (error, '\0', sizeof (*error));
1374 error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1376 error->st.alloc_w_at = (void *) fd_alloc_w_at;
1377 error->st.sfree = (void *) fd_sfree;
1379 error->unbuffered = 1;
1381 return (stream *) error;
1384 /* st_printf()-- simple printf() function for streams that handles the
1385 * formats %d, %s and %c. This function handles printing of error
1386 * messages that originate within the library itself, not from a user
1390 st_printf (const char *format, ...)
1397 char itoa_buf[GFC_ITOA_BUF_SIZE];
1398 unix_stream err_stream;
1401 s = init_error_stream (&err_stream);
1402 va_start (arg, format);
1408 while (format[count] != '%' && format[count] != '\0')
1413 p = salloc_w (s, &count);
1414 memmove (p, format, count);
1420 if (*format++ == '\0')
1428 p = salloc_w (s, &count);
1429 *p = (char) va_arg (arg, int);
1435 q = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
1438 p = salloc_w (s, &count);
1439 memmove (p, q, count);
1444 q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf));
1447 p = salloc_w (s, &count);
1448 memmove (p, q, count);
1453 q = va_arg (arg, char *);
1456 p = salloc_w (s, &count);
1457 memmove (p, q, count);
1466 p = salloc_w (s, &count);
1482 /* compare_file_filename()-- Given an open stream and a fortran string
1483 * that is a filename, figure out if the file is the same as the
1487 compare_file_filename (gfc_unit *u, const char *name, int len)
1489 char path[PATH_MAX + 1];
1491 #ifdef HAVE_WORKING_STAT
1495 if (unpack_filename (path, name, len))
1496 return 0; /* Can't be the same */
1498 /* If the filename doesn't exist, then there is no match with the
1501 if (stat (path, &st1) < 0)
1504 #ifdef HAVE_WORKING_STAT
1505 fstat (((unix_stream *) (u->s))->fd, &st2);
1506 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1508 if (len != u->file_len)
1510 return (memcmp(path, u->file, len) == 0);
1515 #ifdef HAVE_WORKING_STAT
1516 # define FIND_FILE0_DECL struct stat *st
1517 # define FIND_FILE0_ARGS st
1519 # define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
1520 # define FIND_FILE0_ARGS file, file_len
1523 /* find_file0()-- Recursive work function for find_file() */
1526 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1533 #ifdef HAVE_WORKING_STAT
1535 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1536 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1539 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1543 v = find_file0 (u->left, FIND_FILE0_ARGS);
1547 v = find_file0 (u->right, FIND_FILE0_ARGS);
1555 /* find_file()-- Take the current filename and see if there is a unit
1556 * that has the file already open. Returns a pointer to the unit if so. */
1559 find_file (const char *file, gfc_charlen_type file_len)
1561 char path[PATH_MAX + 1];
1565 if (unpack_filename (path, file, file_len))
1568 if (stat (path, &st[0]) < 0)
1571 __gthread_mutex_lock (&unit_lock);
1573 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1577 if (! __gthread_mutex_trylock (&u->lock))
1579 /* assert (u->closed == 0); */
1580 __gthread_mutex_unlock (&unit_lock);
1584 inc_waiting_locked (u);
1586 __gthread_mutex_unlock (&unit_lock);
1589 __gthread_mutex_lock (&u->lock);
1592 __gthread_mutex_lock (&unit_lock);
1593 __gthread_mutex_unlock (&u->lock);
1594 if (predec_waiting_locked (u) == 0)
1599 dec_waiting_unlocked (u);
1605 flush_all_units_1 (gfc_unit *u, int min_unit)
1609 if (u->unit_number > min_unit)
1611 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1615 if (u->unit_number >= min_unit)
1617 if (__gthread_mutex_trylock (&u->lock))
1621 __gthread_mutex_unlock (&u->lock);
1629 flush_all_units (void)
1634 __gthread_mutex_lock (&unit_lock);
1637 u = flush_all_units_1 (unit_root, min_unit);
1639 inc_waiting_locked (u);
1640 __gthread_mutex_unlock (&unit_lock);
1644 __gthread_mutex_lock (&u->lock);
1646 min_unit = u->unit_number + 1;
1651 __gthread_mutex_lock (&unit_lock);
1652 __gthread_mutex_unlock (&u->lock);
1653 (void) predec_waiting_locked (u);
1657 __gthread_mutex_lock (&unit_lock);
1658 __gthread_mutex_unlock (&u->lock);
1659 if (predec_waiting_locked (u) == 0)
1667 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1671 stream_at_bof (stream * s)
1675 if (!is_seekable (s))
1678 us = (unix_stream *) s;
1680 return us->logical_offset == 0;
1684 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1688 stream_at_eof (stream * s)
1692 if (!is_seekable (s))
1695 us = (unix_stream *) s;
1697 return us->logical_offset == us->dirty_offset;
1701 /* delete_file()-- Given a unit structure, delete the file associated
1702 * with the unit. Returns nonzero if something went wrong. */
1705 delete_file (gfc_unit * u)
1707 char path[PATH_MAX + 1];
1709 if (unpack_filename (path, u->file, u->file_len))
1710 { /* Shouldn't be possible */
1715 return unlink (path);
1719 /* file_exists()-- Returns nonzero if the current filename exists on
1723 file_exists (const char *file, gfc_charlen_type file_len)
1725 char path[PATH_MAX + 1];
1726 struct stat statbuf;
1728 if (unpack_filename (path, file, file_len))
1731 if (stat (path, &statbuf) < 0)
1739 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1741 /* inquire_sequential()-- Given a fortran string, determine if the
1742 * file is suitable for sequential access. Returns a C-style
1746 inquire_sequential (const char *string, int len)
1748 char path[PATH_MAX + 1];
1749 struct stat statbuf;
1751 if (string == NULL ||
1752 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1755 if (S_ISREG (statbuf.st_mode) ||
1756 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1759 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1766 /* inquire_direct()-- Given a fortran string, determine if the file is
1767 * suitable for direct access. Returns a C-style string. */
1770 inquire_direct (const char *string, int len)
1772 char path[PATH_MAX + 1];
1773 struct stat statbuf;
1775 if (string == NULL ||
1776 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1779 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1782 if (S_ISDIR (statbuf.st_mode) ||
1783 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1790 /* inquire_formatted()-- Given a fortran string, determine if the file
1791 * is suitable for formatted form. Returns a C-style string. */
1794 inquire_formatted (const char *string, int len)
1796 char path[PATH_MAX + 1];
1797 struct stat statbuf;
1799 if (string == NULL ||
1800 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1803 if (S_ISREG (statbuf.st_mode) ||
1804 S_ISBLK (statbuf.st_mode) ||
1805 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1808 if (S_ISDIR (statbuf.st_mode))
1815 /* inquire_unformatted()-- Given a fortran string, determine if the file
1816 * is suitable for unformatted form. Returns a C-style string. */
1819 inquire_unformatted (const char *string, int len)
1821 return inquire_formatted (string, len);
1825 /* inquire_access()-- Given a fortran string, determine if the file is
1826 * suitable for access. */
1829 inquire_access (const char *string, int len, int mode)
1831 char path[PATH_MAX + 1];
1833 if (string == NULL || unpack_filename (path, string, len) ||
1834 access (path, mode) < 0)
1841 /* inquire_read()-- Given a fortran string, determine if the file is
1842 * suitable for READ access. */
1845 inquire_read (const char *string, int len)
1847 return inquire_access (string, len, R_OK);
1851 /* inquire_write()-- Given a fortran string, determine if the file is
1852 * suitable for READ access. */
1855 inquire_write (const char *string, int len)
1857 return inquire_access (string, len, W_OK);
1861 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1862 * suitable for read and write access. */
1865 inquire_readwrite (const char *string, int len)
1867 return inquire_access (string, len, R_OK | W_OK);
1871 /* file_length()-- Return the file length in bytes, -1 if unknown */
1874 file_length (stream * s)
1876 return ((unix_stream *) s)->file_length;
1880 /* file_position()-- Return the current position of the file */
1883 file_position (stream *s)
1885 return ((unix_stream *) s)->logical_offset;
1889 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1893 is_seekable (stream *s)
1895 /* By convention, if file_length == -1, the file is not
1897 return ((unix_stream *) s)->file_length!=-1;
1901 /* is_special()-- Return nonzero if the stream is not a regular file. */
1904 is_special (stream *s)
1906 return ((unix_stream *) s)->special_file;
1913 return fd_flush( (unix_stream *) s);
1917 stream_isatty (stream *s)
1919 return isatty (((unix_stream *) s)->fd);
1923 stream_ttyname (stream *s)
1926 return ttyname (((unix_stream *) s)->fd);
1933 stream_offset (stream *s)
1935 return (((unix_stream *) s)->logical_offset);
1939 /* How files are stored: This is an operating-system specific issue,
1940 and therefore belongs here. There are three cases to consider.
1943 Records are written as block of bytes corresponding to the record
1944 length of the file. This goes for both formatted and unformatted
1945 records. Positioning is done explicitly for each data transfer,
1946 so positioning is not much of an issue.
1948 Sequential Formatted:
1949 Records are separated by newline characters. The newline character
1950 is prohibited from appearing in a string. If it does, this will be
1951 messed up on the next read. End of file is also the end of a record.
1953 Sequential Unformatted:
1954 In this case, we are merely copying bytes to and from main storage,
1955 yet we need to keep track of varying record lengths. We adopt
1956 the solution used by f2c. Each record contains a pair of length
1959 Length of record n in bytes
1961 Length of record n in bytes
1963 Length of record n+1 in bytes
1965 Length of record n+1 in bytes
1967 The length is stored at the end of a record to allow backspacing to the
1968 previous record. Between data transfer statements, the file pointer
1969 is left pointing to the first length of the current record.
1971 ENDFILE records are never explicitly stored.