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 */
111 char small_buffer[BUFFER_SIZE];
116 /* Stream structure for internal files. Fields must be kept in sync
117 with unix_stream above, except for the buffer. For internal files
118 we point the buffer pointer directly at the destination memory. */
125 gfc_offset buffer_offset; /* File offset of the start of the buffer */
126 gfc_offset physical_offset; /* Current physical file offset */
127 gfc_offset logical_offset; /* Current logical file offset */
128 gfc_offset dirty_offset; /* Start of modified bytes in buffer */
129 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
131 int len; /* Physical length of the current buffer */
132 int active; /* Length of valid bytes in the buffer */
135 int ndirty; /* Dirty bytes starting at dirty_offset */
137 int special_file; /* =1 if the fd refers to a special file */
139 int unbuffered; /* =1 if the stream is not buffered */
145 /* This implementation of stream I/O is based on the paper:
147 * "Exploiting the advantages of mapped files for stream I/O",
148 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
149 * USENIX conference", p. 27-42.
151 * It differs in a number of ways from the version described in the
152 * paper. First of all, threads are not an issue during I/O and we
153 * also don't have to worry about having multiple regions, since
154 * fortran's I/O model only allows you to be one place at a time.
156 * On the other hand, we have to be able to writing at the end of a
157 * stream, read from the start of a stream or read and write blocks of
158 * bytes from an arbitrary position. After opening a file, a pointer
159 * to a stream structure is returned, which is used to handle file
160 * accesses until the file is closed.
162 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
163 * pointer to a block of memory that mirror the file at position
164 * 'where' that is 'len' bytes long. The len integer is updated to
165 * reflect how many bytes were actually read. The only reason for a
166 * short read is end of file. The file pointer is updated. The
167 * pointer is valid until the next call to salloc_*.
169 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
170 * a pointer to a block of memory that is updated to reflect the state
171 * of the file. The length of the buffer is always equal to that
172 * requested. The buffer must be completely set by the caller. When
173 * data has been written, the sfree() function must be called to
174 * indicate that the caller is done writing data to the buffer. This
175 * may or may not cause a physical write.
177 * Short forms of these are salloc_r() and salloc_w() which drop the
178 * 'where' parameter and use the current file pointer. */
181 /*move_pos_offset()-- Move the record pointer right or left
182 *relative to current position */
185 move_pos_offset (stream* st, int pos_off)
187 unix_stream * str = (unix_stream*)st;
190 str->logical_offset += pos_off;
192 if (str->dirty_offset + str->ndirty > str->logical_offset)
194 if (str->ndirty + pos_off > 0)
195 str->ndirty += pos_off;
198 str->dirty_offset += pos_off + pos_off;
209 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
210 * standard descriptors, returning a non-standard descriptor. If the
211 * user specifies that system errors should go to standard output,
212 * then closes standard output, we don't want the system errors to a
213 * file that has been given file descriptor 1 or 0. We want to send
214 * the error to the invalid descriptor. */
219 int input, output, error;
221 input = output = error = 0;
223 /* Unix allocates the lowest descriptors first, so a loop is not
224 required, but this order is. */
226 if (fd == STDIN_FILENO)
231 if (fd == STDOUT_FILENO)
236 if (fd == STDERR_FILENO)
243 close (STDIN_FILENO);
245 close (STDOUT_FILENO);
247 close (STDERR_FILENO);
253 is_preconnected (stream * s)
257 fd = ((unix_stream *) s)->fd;
258 if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO)
264 /* If the stream corresponds to a preconnected unit, we flush the
265 corresponding C stream. This is bugware for mixed C-Fortran codes
266 where the C code doesn't flush I/O before returning. */
268 flush_if_preconnected (stream * s)
272 fd = ((unix_stream *) s)->fd;
273 if (fd == STDIN_FILENO)
275 else if (fd == STDOUT_FILENO)
277 else if (fd == STDERR_FILENO)
282 /* Reset a stream after reading/writing. Assumes that the buffers have
286 reset_stream (unix_stream * s, size_t bytes_rw)
288 s->physical_offset += bytes_rw;
289 s->logical_offset = s->physical_offset;
290 if (s->file_length != -1 && s->physical_offset > s->file_length)
291 s->file_length = s->physical_offset;
295 /* Read bytes into a buffer, allowing for short reads. If the nbytes
296 * argument is less on return than on entry, it is because we've hit
297 * the end of file. */
300 do_read (unix_stream * s, void * buf, size_t * nbytes)
308 bytes_left = *nbytes;
309 buf_st = (char *) buf;
311 /* We must read in a loop since some systems don't restart system
312 calls in case of a signal. */
313 while (bytes_left > 0)
315 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
316 so we must read in chunks smaller than SSIZE_MAX. */
317 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
318 trans = read (s->fd, buf_st, trans);
329 else if (trans == 0) /* We hit EOF. */
335 *nbytes -= bytes_left;
340 /* Write a buffer to a stream, allowing for short writes. */
343 do_write (unix_stream * s, const void * buf, size_t * nbytes)
351 bytes_left = *nbytes;
352 buf_st = (char *) buf;
354 /* We must write in a loop since some systems don't restart system
355 calls in case of a signal. */
356 while (bytes_left > 0)
358 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
359 so we must write in chunks smaller than SSIZE_MAX. */
360 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
361 trans = write (s->fd, buf_st, trans);
376 *nbytes -= bytes_left;
381 /* get_oserror()-- Get the most recent operating system error. For
382 * unix, this is errno. */
387 return strerror (errno);
391 /*********************************************************************
392 File descriptor stream functions
393 *********************************************************************/
396 /* fd_flush()-- Write bytes that need to be written */
399 fd_flush (unix_stream * s)
406 if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
407 lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
410 writelen = s->ndirty;
411 if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
415 s->physical_offset = s->dirty_offset + writelen;
417 /* don't increment file_length if the file is non-seekable */
418 if (s->file_length != -1 && s->physical_offset > s->file_length)
419 s->file_length = s->physical_offset;
421 s->ndirty -= writelen;
429 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
430 * satisfied. This subroutine gets the buffer ready for whatever is
434 fd_alloc (unix_stream * s, gfc_offset where,
435 int *len __attribute__ ((unused)))
440 if (*len <= BUFFER_SIZE)
442 new_buffer = s->small_buffer;
443 read_len = BUFFER_SIZE;
447 new_buffer = get_mem (*len);
451 /* Salvage bytes currently within the buffer. This is important for
452 * devices that cannot seek. */
454 if (s->buffer != NULL && s->buffer_offset <= where &&
455 where <= s->buffer_offset + s->active)
458 n = s->active - (where - s->buffer_offset);
459 memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
464 { /* new buffer starts off empty */
468 s->buffer_offset = where;
470 /* free the old buffer if necessary */
472 if (s->buffer != NULL && s->buffer != s->small_buffer)
473 free_mem (s->buffer);
475 s->buffer = new_buffer;
480 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
481 * we've already buffered the data or we need to load it. Returns
482 * NULL on I/O error. */
485 fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
490 where = s->logical_offset;
492 if (s->buffer != NULL && s->buffer_offset <= where &&
493 where + *len <= s->buffer_offset + s->active)
496 /* Return a position within the current buffer */
498 s->logical_offset = where + *len;
499 return s->buffer + where - s->buffer_offset;
502 fd_alloc (s, where, len);
504 m = where + s->active;
506 if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
509 /* do_read() hangs on read from terminals for *BSD-systems. Only
510 use read() in that case. */
516 n = read (s->fd, s->buffer + s->active, s->len - s->active);
520 s->physical_offset = m + n;
527 n = s->len - s->active;
528 if (do_read (s, s->buffer + s->active, &n) != 0)
531 s->physical_offset = m + n;
535 if (s->active < *len)
536 *len = s->active; /* Bytes actually available */
538 s->logical_offset = where + *len;
544 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
545 * we've already buffered the data or we need to load it. */
548 fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
553 where = s->logical_offset;
555 if (s->buffer == NULL || s->buffer_offset > where ||
556 where + *len > s->buffer_offset + s->len)
559 if (fd_flush (s) == FAILURE)
561 fd_alloc (s, where, len);
564 /* Return a position within the current buffer */
566 || where > s->dirty_offset + s->ndirty
567 || s->dirty_offset > where + *len)
568 { /* Discontiguous blocks, start with a clean buffer. */
569 /* Flush the buffer. */
572 s->dirty_offset = where;
577 gfc_offset start; /* Merge with the existing data. */
578 if (where < s->dirty_offset)
581 start = s->dirty_offset;
582 if (where + *len > s->dirty_offset + s->ndirty)
583 s->ndirty = where + *len - start;
585 s->ndirty = s->dirty_offset + s->ndirty - start;
586 s->dirty_offset = start;
589 s->logical_offset = where + *len;
591 /* Don't increment file_length if the file is non-seekable. */
593 if (s->file_length != -1 && s->logical_offset > s->file_length)
594 s->file_length = s->logical_offset;
596 n = s->logical_offset - s->buffer_offset;
600 return s->buffer + where - s->buffer_offset;
605 fd_sfree (unix_stream * s)
607 if (s->ndirty != 0 &&
608 (s->buffer != s->small_buffer || options.all_unbuffered ||
617 fd_seek (unix_stream * s, gfc_offset offset)
620 if (s->file_length == -1)
623 if (s->physical_offset == offset) /* Are we lucky and avoid syscall? */
625 s->logical_offset = offset;
629 if (lseek (s->fd, offset, SEEK_SET) >= 0)
631 s->physical_offset = s->logical_offset = offset;
640 /* truncate_file()-- Given a unit, truncate the file at the current
641 * position. Sets the physical location to the new end of the file.
642 * Returns nonzero on error. */
645 fd_truncate (unix_stream * s)
647 /* Non-seekable files, like terminals and fifo's fail the lseek so just
648 return success, there is nothing to truncate. If its not a pipe there
649 is a real problem. */
650 if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
658 /* Using ftruncate on a seekable special file (like /dev/null)
659 is undefined, so we treat it as if the ftruncate succeeded. */
660 #ifdef HAVE_FTRUNCATE
661 if (s->special_file || ftruncate (s->fd, s->logical_offset))
664 if (s->special_file || chsize (s->fd, s->logical_offset))
668 s->physical_offset = s->file_length = 0;
672 s->physical_offset = s->file_length = s->logical_offset;
678 /* Similar to memset(), but operating on a stream instead of a string.
679 Takes care of not using too much memory. */
682 fd_sset (unix_stream * s, int c, size_t n)
690 while (bytes_left > 0)
692 /* memset() in chunks of BUFFER_SIZE. */
693 trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
695 p = fd_alloc_w_at (s, &trans, -1);
697 memset (p, c, trans);
708 /* Stream read function. Avoids using a buffer for big reads. The
709 interface is like POSIX read(), but the nbytes argument is a
710 pointer; on return it contains the number of bytes written. The
711 function return value is the status indicator (0 for success). */
714 fd_read (unix_stream * s, void * buf, size_t * nbytes)
719 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
722 p = fd_alloc_r_at (s, &tmp, -1);
726 memcpy (buf, p, *nbytes);
736 /* If the request is bigger than BUFFER_SIZE we flush the buffers
737 and read directly. */
738 if (fd_flush (s) == FAILURE)
744 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
750 status = do_read (s, buf, nbytes);
751 reset_stream (s, *nbytes);
756 /* Stream write function. Avoids using a buffer for big writes. The
757 interface is like POSIX write(), but the nbytes argument is a
758 pointer; on return it contains the number of bytes written. The
759 function return value is the status indicator (0 for success). */
762 fd_write (unix_stream * s, const void * buf, size_t * nbytes)
767 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
770 p = fd_alloc_w_at (s, &tmp, -1);
774 memcpy (p, buf, *nbytes);
784 /* If the request is bigger than BUFFER_SIZE we flush the buffers
785 and write directly. */
786 if (fd_flush (s) == FAILURE)
792 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
798 status = do_write (s, buf, nbytes);
799 reset_stream (s, *nbytes);
805 fd_close (unix_stream * s)
807 if (fd_flush (s) == FAILURE)
810 if (s->buffer != NULL && s->buffer != s->small_buffer)
811 free_mem (s->buffer);
813 if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO)
815 if (close (s->fd) < 0)
826 fd_open (unix_stream * s)
831 s->st.alloc_r_at = (void *) fd_alloc_r_at;
832 s->st.alloc_w_at = (void *) fd_alloc_w_at;
833 s->st.sfree = (void *) fd_sfree;
834 s->st.close = (void *) fd_close;
835 s->st.seek = (void *) fd_seek;
836 s->st.truncate = (void *) fd_truncate;
837 s->st.read = (void *) fd_read;
838 s->st.write = (void *) fd_write;
839 s->st.set = (void *) fd_sset;
847 /*********************************************************************
848 memory stream functions - These are used for internal files
850 The idea here is that a single stream structure is created and all
851 requests must be satisfied from it. The location and size of the
852 buffer is the character variable supplied to the READ or WRITE
855 *********************************************************************/
859 mem_alloc_r_at (int_stream * s, int *len, gfc_offset where)
864 where = s->logical_offset;
866 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
869 s->logical_offset = where + *len;
871 n = s->buffer_offset + s->active - where;
875 return s->buffer + (where - s->buffer_offset);
880 mem_alloc_w_at (int_stream * s, int *len, gfc_offset where)
884 assert (*len >= 0); /* Negative values not allowed. */
887 where = s->logical_offset;
891 if (where < s->buffer_offset)
894 if (m > s->file_length)
897 s->logical_offset = m;
899 return s->buffer + (where - s->buffer_offset);
903 /* Stream read function for internal units. This is not actually used
904 at the moment, as all internal IO is formatted and the formatted IO
905 routines use mem_alloc_r_at. */
908 mem_read (int_stream * s, void * buf, size_t * nbytes)
914 p = mem_alloc_r_at (s, &tmp, -1);
918 memcpy (buf, p, *nbytes);
929 /* Stream write function for internal units. This is not actually used
930 at the moment, as all internal IO is formatted and the formatted IO
931 routines use mem_alloc_w_at. */
934 mem_write (int_stream * s, const void * buf, size_t * nbytes)
942 p = mem_alloc_w_at (s, &tmp, -1);
946 memcpy (p, buf, *nbytes);
958 mem_seek (int_stream * s, gfc_offset offset)
960 if (offset > s->file_length)
966 s->logical_offset = offset;
972 mem_set (int_stream * s, int c, size_t n)
979 p = mem_alloc_w_at (s, &len, -1);
991 mem_truncate (int_stream * s __attribute__ ((unused)))
998 mem_close (int_stream * s)
1008 mem_sfree (int_stream * s __attribute__ ((unused)))
1015 /*********************************************************************
1016 Public functions -- A reimplementation of this module needs to
1017 define functional equivalents of the following.
1018 *********************************************************************/
1020 /* empty_internal_buffer()-- Zero the buffer of Internal file */
1023 empty_internal_buffer(stream *strm)
1025 int_stream * s = (int_stream *) strm;
1026 memset(s->buffer, ' ', s->file_length);
1029 /* open_internal()-- Returns a stream structure from an internal file */
1032 open_internal (char *base, int length)
1036 s = get_mem (sizeof (int_stream));
1037 memset (s, '\0', sizeof (int_stream));
1040 s->buffer_offset = 0;
1042 s->logical_offset = 0;
1043 s->active = s->file_length = length;
1045 s->st.alloc_r_at = (void *) mem_alloc_r_at;
1046 s->st.alloc_w_at = (void *) mem_alloc_w_at;
1047 s->st.sfree = (void *) mem_sfree;
1048 s->st.close = (void *) mem_close;
1049 s->st.seek = (void *) mem_seek;
1050 s->st.truncate = (void *) mem_truncate;
1051 s->st.read = (void *) mem_read;
1052 s->st.write = (void *) mem_write;
1053 s->st.set = (void *) mem_set;
1055 return (stream *) s;
1059 /* fd_to_stream()-- Given an open file descriptor, build a stream
1063 fd_to_stream (int fd, int prot)
1065 struct stat statbuf;
1068 s = get_mem (sizeof (unix_stream));
1069 memset (s, '\0', sizeof (unix_stream));
1072 s->buffer_offset = 0;
1073 s->physical_offset = 0;
1074 s->logical_offset = 0;
1077 /* Get the current length of the file. */
1079 fstat (fd, &statbuf);
1081 if (lseek (fd, 0, SEEK_CUR) == (off_t) -1)
1082 s->file_length = -1;
1084 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
1086 s->special_file = !S_ISREG (statbuf.st_mode);
1090 return (stream *) s;
1094 /* Given the Fortran unit number, convert it to a C file descriptor. */
1097 unit_to_fd (int unit)
1102 us = find_unit (unit);
1106 fd = ((unix_stream *) us->s)->fd;
1112 /* unpack_filename()-- Given a fortran string and a pointer to a
1113 * buffer that is PATH_MAX characters, convert the fortran string to a
1114 * C string in the buffer. Returns nonzero if this is not possible. */
1117 unpack_filename (char *cstring, const char *fstring, int len)
1119 len = fstrlen (fstring, len);
1120 if (len >= PATH_MAX)
1123 memmove (cstring, fstring, len);
1124 cstring[len] = '\0';
1130 /* tempfile()-- Generate a temporary filename for a scratch file and
1131 * open it. mkstemp() opens the file for reading and writing, but the
1132 * library mode prevents anything that is not allowed. The descriptor
1133 * is returned, which is -1 on error. The template is pointed to by
1134 * opp->file, which is copied into the unit structure
1135 * and freed later. */
1138 tempfile (st_parameter_open *opp)
1140 const char *tempdir;
1144 tempdir = getenv ("GFORTRAN_TMPDIR");
1145 if (tempdir == NULL)
1146 tempdir = getenv ("TMP");
1147 if (tempdir == NULL)
1148 tempdir = getenv ("TEMP");
1149 if (tempdir == NULL)
1150 tempdir = DEFAULT_TEMPDIR;
1152 template = get_mem (strlen (tempdir) + 20);
1154 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
1158 fd = mkstemp (template);
1160 #else /* HAVE_MKSTEMP */
1162 if (mktemp (template))
1164 #if defined(HAVE_CRLF) && defined(O_BINARY)
1165 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1166 S_IREAD | S_IWRITE);
1168 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1170 while (!(fd == -1 && errno == EEXIST) && mktemp (template));
1174 #endif /* HAVE_MKSTEMP */
1177 free_mem (template);
1180 opp->file = template;
1181 opp->file_len = strlen (template); /* Don't include trailing nul */
1188 /* regular_file()-- Open a regular file.
1189 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1190 * unless an error occurs.
1191 * Returns the descriptor, which is less than zero on error. */
1194 regular_file (st_parameter_open *opp, unit_flags *flags)
1196 char path[PATH_MAX + 1];
1202 if (unpack_filename (path, opp->file, opp->file_len))
1204 errno = ENOENT; /* Fake an OS error */
1210 switch (flags->action)
1220 case ACTION_READWRITE:
1221 case ACTION_UNSPECIFIED:
1226 internal_error (&opp->common, "regular_file(): Bad action");
1229 switch (flags->status)
1232 crflag = O_CREAT | O_EXCL;
1235 case STATUS_OLD: /* open will fail if the file does not exist*/
1239 case STATUS_UNKNOWN:
1240 case STATUS_SCRATCH:
1244 case STATUS_REPLACE:
1245 crflag = O_CREAT | O_TRUNC;
1249 internal_error (&opp->common, "regular_file(): Bad status");
1252 /* rwflag |= O_LARGEFILE; */
1254 #if defined(HAVE_CRLF) && defined(O_BINARY)
1258 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1259 fd = open (path, rwflag | crflag, mode);
1260 if (flags->action != ACTION_UNSPECIFIED)
1265 flags->action = ACTION_READWRITE;
1268 if (errno != EACCES && errno != EROFS)
1271 /* retry for read-only access */
1273 fd = open (path, rwflag | crflag, mode);
1276 flags->action = ACTION_READ;
1277 return fd; /* success */
1280 if (errno != EACCES)
1281 return fd; /* failure */
1283 /* retry for write-only access */
1285 fd = open (path, rwflag | crflag, mode);
1288 flags->action = ACTION_WRITE;
1289 return fd; /* success */
1291 return fd; /* failure */
1295 /* open_external()-- Open an external file, unix specific version.
1296 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1297 * Returns NULL on operating system error. */
1300 open_external (st_parameter_open *opp, unit_flags *flags)
1304 if (flags->status == STATUS_SCRATCH)
1306 fd = tempfile (opp);
1307 if (flags->action == ACTION_UNSPECIFIED)
1308 flags->action = ACTION_READWRITE;
1310 #if HAVE_UNLINK_OPEN_FILE
1311 /* We can unlink scratch files now and it will go away when closed. */
1318 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1320 fd = regular_file (opp, flags);
1327 switch (flags->action)
1337 case ACTION_READWRITE:
1338 prot = PROT_READ | PROT_WRITE;
1342 internal_error (&opp->common, "open_external(): Bad action");
1345 return fd_to_stream (fd, prot);
1349 /* input_stream()-- Return a stream pointer to the default input stream.
1350 * Called on initialization. */
1355 return fd_to_stream (STDIN_FILENO, PROT_READ);
1359 /* output_stream()-- Return a stream pointer to the default output stream.
1360 * Called on initialization. */
1363 output_stream (void)
1365 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1366 setmode (STDOUT_FILENO, O_BINARY);
1368 return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1372 /* error_stream()-- Return a stream pointer to the default error stream.
1373 * Called on initialization. */
1378 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1379 setmode (STDERR_FILENO, O_BINARY);
1381 return fd_to_stream (STDERR_FILENO, PROT_WRITE);
1385 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1386 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1387 is big enough to completely fill a 80x25 terminal, so it shuld be
1388 OK. We use a direct write() because it is simpler and least likely
1389 to be clobbered by memory corruption. */
1391 #define ST_VPRINTF_SIZE 2048
1394 st_vprintf (const char *format, va_list ap)
1396 static char buffer[ST_VPRINTF_SIZE];
1400 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1401 #ifdef HAVE_VSNPRINTF
1402 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1404 written = __builtin_vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1406 written = write (fd, buffer, written);
1410 /* st_printf()-- printf() function for error output. This just calls
1411 st_vprintf() to do the actual work. */
1414 st_printf (const char *format, ...)
1418 va_start (ap, format);
1419 written = st_vprintf(format, ap);
1425 /* compare_file_filename()-- Given an open stream and a fortran string
1426 * that is a filename, figure out if the file is the same as the
1430 compare_file_filename (gfc_unit *u, const char *name, int len)
1432 char path[PATH_MAX + 1];
1434 #ifdef HAVE_WORKING_STAT
1438 if (unpack_filename (path, name, len))
1439 return 0; /* Can't be the same */
1441 /* If the filename doesn't exist, then there is no match with the
1444 if (stat (path, &st1) < 0)
1447 #ifdef HAVE_WORKING_STAT
1448 fstat (((unix_stream *) (u->s))->fd, &st2);
1449 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1451 if (len != u->file_len)
1453 return (memcmp(path, u->file, len) == 0);
1458 #ifdef HAVE_WORKING_STAT
1459 # define FIND_FILE0_DECL struct stat *st
1460 # define FIND_FILE0_ARGS st
1462 # define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
1463 # define FIND_FILE0_ARGS file, file_len
1466 /* find_file0()-- Recursive work function for find_file() */
1469 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1476 #ifdef HAVE_WORKING_STAT
1478 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1479 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1482 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1486 v = find_file0 (u->left, FIND_FILE0_ARGS);
1490 v = find_file0 (u->right, FIND_FILE0_ARGS);
1498 /* find_file()-- Take the current filename and see if there is a unit
1499 * that has the file already open. Returns a pointer to the unit if so. */
1502 find_file (const char *file, gfc_charlen_type file_len)
1504 char path[PATH_MAX + 1];
1508 if (unpack_filename (path, file, file_len))
1511 if (stat (path, &st[0]) < 0)
1514 __gthread_mutex_lock (&unit_lock);
1516 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1520 if (! __gthread_mutex_trylock (&u->lock))
1522 /* assert (u->closed == 0); */
1523 __gthread_mutex_unlock (&unit_lock);
1527 inc_waiting_locked (u);
1529 __gthread_mutex_unlock (&unit_lock);
1532 __gthread_mutex_lock (&u->lock);
1535 __gthread_mutex_lock (&unit_lock);
1536 __gthread_mutex_unlock (&u->lock);
1537 if (predec_waiting_locked (u) == 0)
1542 dec_waiting_unlocked (u);
1548 flush_all_units_1 (gfc_unit *u, int min_unit)
1552 if (u->unit_number > min_unit)
1554 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1558 if (u->unit_number >= min_unit)
1560 if (__gthread_mutex_trylock (&u->lock))
1564 __gthread_mutex_unlock (&u->lock);
1572 flush_all_units (void)
1577 __gthread_mutex_lock (&unit_lock);
1580 u = flush_all_units_1 (unit_root, min_unit);
1582 inc_waiting_locked (u);
1583 __gthread_mutex_unlock (&unit_lock);
1587 __gthread_mutex_lock (&u->lock);
1589 min_unit = u->unit_number + 1;
1594 __gthread_mutex_lock (&unit_lock);
1595 __gthread_mutex_unlock (&u->lock);
1596 (void) predec_waiting_locked (u);
1600 __gthread_mutex_lock (&unit_lock);
1601 __gthread_mutex_unlock (&u->lock);
1602 if (predec_waiting_locked (u) == 0)
1610 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1614 stream_at_bof (stream * s)
1618 if (!is_seekable (s))
1621 us = (unix_stream *) s;
1623 return us->logical_offset == 0;
1627 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1631 stream_at_eof (stream * s)
1635 if (!is_seekable (s))
1638 us = (unix_stream *) s;
1640 return us->logical_offset == us->dirty_offset;
1644 /* delete_file()-- Given a unit structure, delete the file associated
1645 * with the unit. Returns nonzero if something went wrong. */
1648 delete_file (gfc_unit * u)
1650 char path[PATH_MAX + 1];
1652 if (unpack_filename (path, u->file, u->file_len))
1653 { /* Shouldn't be possible */
1658 return unlink (path);
1662 /* file_exists()-- Returns nonzero if the current filename exists on
1666 file_exists (const char *file, gfc_charlen_type file_len)
1668 char path[PATH_MAX + 1];
1669 struct stat statbuf;
1671 if (unpack_filename (path, file, file_len))
1674 if (stat (path, &statbuf) < 0)
1682 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1684 /* inquire_sequential()-- Given a fortran string, determine if the
1685 * file is suitable for sequential access. Returns a C-style
1689 inquire_sequential (const char *string, int len)
1691 char path[PATH_MAX + 1];
1692 struct stat statbuf;
1694 if (string == NULL ||
1695 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1698 if (S_ISREG (statbuf.st_mode) ||
1699 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1702 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1709 /* inquire_direct()-- Given a fortran string, determine if the file is
1710 * suitable for direct access. Returns a C-style string. */
1713 inquire_direct (const char *string, int len)
1715 char path[PATH_MAX + 1];
1716 struct stat statbuf;
1718 if (string == NULL ||
1719 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1722 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1725 if (S_ISDIR (statbuf.st_mode) ||
1726 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1733 /* inquire_formatted()-- Given a fortran string, determine if the file
1734 * is suitable for formatted form. Returns a C-style string. */
1737 inquire_formatted (const char *string, int len)
1739 char path[PATH_MAX + 1];
1740 struct stat statbuf;
1742 if (string == NULL ||
1743 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1746 if (S_ISREG (statbuf.st_mode) ||
1747 S_ISBLK (statbuf.st_mode) ||
1748 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1751 if (S_ISDIR (statbuf.st_mode))
1758 /* inquire_unformatted()-- Given a fortran string, determine if the file
1759 * is suitable for unformatted form. Returns a C-style string. */
1762 inquire_unformatted (const char *string, int len)
1764 return inquire_formatted (string, len);
1768 /* inquire_access()-- Given a fortran string, determine if the file is
1769 * suitable for access. */
1772 inquire_access (const char *string, int len, int mode)
1774 char path[PATH_MAX + 1];
1776 if (string == NULL || unpack_filename (path, string, len) ||
1777 access (path, mode) < 0)
1784 /* inquire_read()-- Given a fortran string, determine if the file is
1785 * suitable for READ access. */
1788 inquire_read (const char *string, int len)
1790 return inquire_access (string, len, R_OK);
1794 /* inquire_write()-- Given a fortran string, determine if the file is
1795 * suitable for READ access. */
1798 inquire_write (const char *string, int len)
1800 return inquire_access (string, len, W_OK);
1804 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1805 * suitable for read and write access. */
1808 inquire_readwrite (const char *string, int len)
1810 return inquire_access (string, len, R_OK | W_OK);
1814 /* file_length()-- Return the file length in bytes, -1 if unknown */
1817 file_length (stream * s)
1819 return ((unix_stream *) s)->file_length;
1823 /* file_position()-- Return the current position of the file */
1826 file_position (stream *s)
1828 return ((unix_stream *) s)->logical_offset;
1832 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1836 is_seekable (stream *s)
1838 /* By convention, if file_length == -1, the file is not
1840 return ((unix_stream *) s)->file_length!=-1;
1844 /* is_special()-- Return nonzero if the stream is not a regular file. */
1847 is_special (stream *s)
1849 return ((unix_stream *) s)->special_file;
1856 return fd_flush( (unix_stream *) s);
1860 stream_isatty (stream *s)
1862 return isatty (((unix_stream *) s)->fd);
1866 stream_ttyname (stream *s __attribute__ ((unused)))
1869 return ttyname (((unix_stream *) s)->fd);
1876 stream_offset (stream *s)
1878 return (((unix_stream *) s)->logical_offset);
1882 /* How files are stored: This is an operating-system specific issue,
1883 and therefore belongs here. There are three cases to consider.
1886 Records are written as block of bytes corresponding to the record
1887 length of the file. This goes for both formatted and unformatted
1888 records. Positioning is done explicitly for each data transfer,
1889 so positioning is not much of an issue.
1891 Sequential Formatted:
1892 Records are separated by newline characters. The newline character
1893 is prohibited from appearing in a string. If it does, this will be
1894 messed up on the next read. End of file is also the end of a record.
1896 Sequential Unformatted:
1897 In this case, we are merely copying bytes to and from main storage,
1898 yet we need to keep track of varying record lengths. We adopt
1899 the solution used by f2c. Each record contains a pair of length
1902 Length of record n in bytes
1904 Length of record n in bytes
1906 Length of record n+1 in bytes
1908 Length of record n+1 in bytes
1910 The length is stored at the end of a record to allow backspacing to the
1911 previous record. Between data transfer statements, the file pointer
1912 is left pointing to the first length of the current record.
1914 ENDFILE records are never explicitly stored.