1 /* Copyright (C) 2002, 2003, 2004, 2005
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 /* Unix stream I/O module */
46 #include "libgfortran.h"
51 #define SSIZE_MAX SHRT_MAX
66 /* These flags aren't defined on all targets (mingw32), so provide them
84 /* This implementation of stream I/O is based on the paper:
86 * "Exploiting the advantages of mapped files for stream I/O",
87 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
88 * USENIX conference", p. 27-42.
90 * It differs in a number of ways from the version described in the
91 * paper. First of all, threads are not an issue during I/O and we
92 * also don't have to worry about having multiple regions, since
93 * fortran's I/O model only allows you to be one place at a time.
95 * On the other hand, we have to be able to writing at the end of a
96 * stream, read from the start of a stream or read and write blocks of
97 * bytes from an arbitrary position. After opening a file, a pointer
98 * to a stream structure is returned, which is used to handle file
99 * accesses until the file is closed.
101 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
102 * pointer to a block of memory that mirror the file at position
103 * 'where' that is 'len' bytes long. The len integer is updated to
104 * reflect how many bytes were actually read. The only reason for a
105 * short read is end of file. The file pointer is updated. The
106 * pointer is valid until the next call to salloc_*.
108 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
109 * a pointer to a block of memory that is updated to reflect the state
110 * of the file. The length of the buffer is always equal to that
111 * requested. The buffer must be completely set by the caller. When
112 * data has been written, the sfree() function must be called to
113 * indicate that the caller is done writing data to the buffer. This
114 * may or may not cause a physical write.
116 * Short forms of these are salloc_r() and salloc_w() which drop the
117 * 'where' parameter and use the current file pointer. */
120 /*move_pos_offset()-- Move the record pointer right or left
121 *relative to current position */
124 move_pos_offset (stream* st, int pos_off)
126 unix_stream * str = (unix_stream*)st;
129 str->logical_offset += pos_off;
131 if (str->dirty_offset + str->ndirty > str->logical_offset)
133 if (str->ndirty + pos_off > 0)
134 str->ndirty += pos_off;
137 str->dirty_offset += pos_off + pos_off;
148 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
149 * standard descriptors, returning a non-standard descriptor. If the
150 * user specifies that system errors should go to standard output,
151 * then closes standard output, we don't want the system errors to a
152 * file that has been given file descriptor 1 or 0. We want to send
153 * the error to the invalid descriptor. */
158 int input, output, error;
160 input = output = error = 0;
162 /* Unix allocates the lowest descriptors first, so a loop is not
163 required, but this order is. */
165 if (fd == STDIN_FILENO)
170 if (fd == STDOUT_FILENO)
175 if (fd == STDERR_FILENO)
182 close (STDIN_FILENO);
184 close (STDOUT_FILENO);
186 close (STDERR_FILENO);
192 is_preconnected (stream * s)
196 fd = ((unix_stream *) s)->fd;
197 if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO)
203 /* If the stream corresponds to a preconnected unit, we flush the
204 corresponding C stream. This is bugware for mixed C-Fortran codes
205 where the C code doesn't flush I/O before returning. */
207 flush_if_preconnected (stream * s)
211 fd = ((unix_stream *) s)->fd;
212 if (fd == STDIN_FILENO)
214 else if (fd == STDOUT_FILENO)
216 else if (fd == STDERR_FILENO)
221 /* Reset a stream after reading/writing. Assumes that the buffers have
225 reset_stream (unix_stream * s, size_t bytes_rw)
227 s->physical_offset += bytes_rw;
228 s->logical_offset = s->physical_offset;
229 if (s->file_length != -1 && s->physical_offset > s->file_length)
230 s->file_length = s->physical_offset;
234 /* Read bytes into a buffer, allowing for short reads. If the nbytes
235 * argument is less on return than on entry, it is because we've hit
236 * the end of file. */
239 do_read (unix_stream * s, void * buf, size_t * nbytes)
247 bytes_left = *nbytes;
248 buf_st = (char *) buf;
250 /* We must read in a loop since some systems don't restart system
251 calls in case of a signal. */
252 while (bytes_left > 0)
254 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
255 so we must read in chunks smaller than SSIZE_MAX. */
256 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
257 trans = read (s->fd, buf_st, trans);
268 else if (trans == 0) /* We hit EOF. */
274 *nbytes -= bytes_left;
279 /* Write a buffer to a stream, allowing for short writes. */
282 do_write (unix_stream * s, const void * buf, size_t * nbytes)
290 bytes_left = *nbytes;
291 buf_st = (char *) buf;
293 /* We must write in a loop since some systems don't restart system
294 calls in case of a signal. */
295 while (bytes_left > 0)
297 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
298 so we must write in chunks smaller than SSIZE_MAX. */
299 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
300 trans = write (s->fd, buf_st, trans);
315 *nbytes -= bytes_left;
320 /* get_oserror()-- Get the most recent operating system error. For
321 * unix, this is errno. */
326 return strerror (errno);
330 /* sys_exit()-- Terminate the program with an exit code */
339 /*********************************************************************
340 File descriptor stream functions
341 *********************************************************************/
344 /* fd_flush()-- Write bytes that need to be written */
347 fd_flush (unix_stream * s)
354 if (s->physical_offset != s->dirty_offset &&
355 lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
358 writelen = s->ndirty;
359 if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
363 s->physical_offset = s->dirty_offset + writelen;
365 /* don't increment file_length if the file is non-seekable */
366 if (s->file_length != -1 && s->physical_offset > s->file_length)
367 s->file_length = s->physical_offset;
369 s->ndirty -= writelen;
377 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
378 * satisfied. This subroutine gets the buffer ready for whatever is
382 fd_alloc (unix_stream * s, gfc_offset where,
383 int *len __attribute__ ((unused)))
388 if (*len <= BUFFER_SIZE)
390 new_buffer = s->small_buffer;
391 read_len = BUFFER_SIZE;
395 new_buffer = get_mem (*len);
399 /* Salvage bytes currently within the buffer. This is important for
400 * devices that cannot seek. */
402 if (s->buffer != NULL && s->buffer_offset <= where &&
403 where <= s->buffer_offset + s->active)
406 n = s->active - (where - s->buffer_offset);
407 memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
412 { /* new buffer starts off empty */
416 s->buffer_offset = where;
418 /* free the old buffer if necessary */
420 if (s->buffer != NULL && s->buffer != s->small_buffer)
421 free_mem (s->buffer);
423 s->buffer = new_buffer;
428 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
429 * we've already buffered the data or we need to load it. Returns
430 * NULL on I/O error. */
433 fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
438 where = s->logical_offset;
440 if (s->buffer != NULL && s->buffer_offset <= where &&
441 where + *len <= s->buffer_offset + s->active)
444 /* Return a position within the current buffer */
446 s->logical_offset = where + *len;
447 return s->buffer + where - s->buffer_offset;
450 fd_alloc (s, where, len);
452 m = where + s->active;
454 if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
457 /* do_read() hangs on read from terminals for *BSD-systems. Only
458 use read() in that case. */
464 n = read (s->fd, s->buffer + s->active, s->len - s->active);
468 s->physical_offset = where + n;
475 n = s->len - s->active;
476 if (do_read (s, s->buffer + s->active, &n) != 0)
479 s->physical_offset = where + n;
483 if (s->active < *len)
484 *len = s->active; /* Bytes actually available */
486 s->logical_offset = where + *len;
492 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
493 * we've already buffered the data or we need to load it. */
496 fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
501 where = s->logical_offset;
503 if (s->buffer == NULL || s->buffer_offset > where ||
504 where + *len > s->buffer_offset + s->len)
507 if (fd_flush (s) == FAILURE)
509 fd_alloc (s, where, len);
512 /* Return a position within the current buffer */
514 || where > s->dirty_offset + s->ndirty
515 || s->dirty_offset > where + *len)
516 { /* Discontiguous blocks, start with a clean buffer. */
517 /* Flush the buffer. */
520 s->dirty_offset = where;
525 gfc_offset start; /* Merge with the existing data. */
526 if (where < s->dirty_offset)
529 start = s->dirty_offset;
530 if (where + *len > s->dirty_offset + s->ndirty)
531 s->ndirty = where + *len - start;
533 s->ndirty = s->dirty_offset + s->ndirty - start;
534 s->dirty_offset = start;
537 s->logical_offset = where + *len;
539 if (where + *len > s->file_length)
540 s->file_length = where + *len;
542 n = s->logical_offset - s->buffer_offset;
546 return s->buffer + where - s->buffer_offset;
551 fd_sfree (unix_stream * s)
553 if (s->ndirty != 0 &&
554 (s->buffer != s->small_buffer || options.all_unbuffered ||
563 fd_seek (unix_stream * s, gfc_offset offset)
565 if (s->physical_offset == offset) /* Are we lucky and avoid syscall? */
567 s->logical_offset = offset;
571 s->physical_offset = s->logical_offset = offset;
574 return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
578 /* truncate_file()-- Given a unit, truncate the file at the current
579 * position. Sets the physical location to the new end of the file.
580 * Returns nonzero on error. */
583 fd_truncate (unix_stream * s)
585 if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
588 /* non-seekable files, like terminals and fifo's fail the lseek.
589 Using ftruncate on a seekable special file (like /dev/null)
590 is undefined, so we treat it as if the ftruncate succeeded.
592 #ifdef HAVE_FTRUNCATE
593 if (s->special_file || ftruncate (s->fd, s->logical_offset))
596 if (s->special_file || chsize (s->fd, s->logical_offset))
600 s->physical_offset = s->file_length = 0;
604 s->physical_offset = s->file_length = s->logical_offset;
610 /* Similar to memset(), but operating on a stream instead of a string.
611 Takes care of not using too much memory. */
614 fd_sset (unix_stream * s, int c, size_t n)
622 while (bytes_left > 0)
624 /* memset() in chunks of BUFFER_SIZE. */
625 trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
627 p = fd_alloc_w_at (s, &trans, -1);
629 memset (p, c, trans);
640 /* Stream read function. Avoids using a buffer for big reads. The
641 interface is like POSIX read(), but the nbytes argument is a
642 pointer; on return it contains the number of bytes written. The
643 function return value is the status indicator (0 for success). */
646 fd_read (unix_stream * s, void * buf, size_t * nbytes)
651 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
654 p = fd_alloc_r_at (s, &tmp, -1);
658 memcpy (buf, p, *nbytes);
668 /* If the request is bigger than BUFFER_SIZE we flush the buffers
669 and read directly. */
670 if (fd_flush (s) == FAILURE)
676 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
682 status = do_read (s, buf, nbytes);
683 reset_stream (s, *nbytes);
688 /* Stream write function. Avoids using a buffer for big writes. The
689 interface is like POSIX write(), but the nbytes argument is a
690 pointer; on return it contains the number of bytes written. The
691 function return value is the status indicator (0 for success). */
694 fd_write (unix_stream * s, const void * buf, size_t * nbytes)
699 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
702 p = fd_alloc_w_at (s, &tmp, -1);
706 memcpy (p, buf, *nbytes);
716 /* If the request is bigger than BUFFER_SIZE we flush the buffers
717 and write directly. */
718 if (fd_flush (s) == FAILURE)
724 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
730 status = do_write (s, buf, nbytes);
731 reset_stream (s, *nbytes);
737 fd_close (unix_stream * s)
739 if (fd_flush (s) == FAILURE)
742 if (s->buffer != NULL && s->buffer != s->small_buffer)
743 free_mem (s->buffer);
745 if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO)
747 if (close (s->fd) < 0)
758 fd_open (unix_stream * s)
763 s->st.alloc_r_at = (void *) fd_alloc_r_at;
764 s->st.alloc_w_at = (void *) fd_alloc_w_at;
765 s->st.sfree = (void *) fd_sfree;
766 s->st.close = (void *) fd_close;
767 s->st.seek = (void *) fd_seek;
768 s->st.truncate = (void *) fd_truncate;
769 s->st.read = (void *) fd_read;
770 s->st.write = (void *) fd_write;
771 s->st.set = (void *) fd_sset;
779 /*********************************************************************
780 memory stream functions - These are used for internal files
782 The idea here is that a single stream structure is created and all
783 requests must be satisfied from it. The location and size of the
784 buffer is the character variable supplied to the READ or WRITE
787 *********************************************************************/
791 mem_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
796 where = s->logical_offset;
798 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
801 s->logical_offset = where + *len;
803 n = s->buffer_offset + s->active - where;
807 return s->buffer + (where - s->buffer_offset);
812 mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
816 assert (*len >= 0); /* Negative values not allowed. */
819 where = s->logical_offset;
823 if (where < s->buffer_offset)
826 if (m > s->file_length)
829 s->logical_offset = m;
831 return s->buffer + (where - s->buffer_offset);
835 /* Stream read function for internal units. This is not actually used
836 at the moment, as all internal IO is formatted and the formatted IO
837 routines use mem_alloc_r_at. */
840 mem_read (unix_stream * s, void * buf, size_t * nbytes)
846 p = mem_alloc_r_at (s, &tmp, -1);
850 memcpy (buf, p, *nbytes);
861 /* Stream write function for internal units. This is not actually used
862 at the moment, as all internal IO is formatted and the formatted IO
863 routines use mem_alloc_w_at. */
866 mem_write (unix_stream * s, const void * buf, size_t * nbytes)
874 p = mem_alloc_w_at (s, &tmp, -1);
878 memcpy (p, buf, *nbytes);
890 mem_seek (unix_stream * s, gfc_offset offset)
892 if (offset > s->file_length)
898 s->logical_offset = offset;
904 mem_set (unix_stream * s, int c, size_t n)
911 p = mem_alloc_w_at (s, &len, -1);
923 mem_truncate (unix_stream * s __attribute__ ((unused)))
930 mem_close (unix_stream * s)
940 mem_sfree (unix_stream * s __attribute__ ((unused)))
947 /*********************************************************************
948 Public functions -- A reimplementation of this module needs to
949 define functional equivalents of the following.
950 *********************************************************************/
952 /* empty_internal_buffer()-- Zero the buffer of Internal file */
955 empty_internal_buffer(stream *strm)
957 unix_stream * s = (unix_stream *) strm;
958 memset(s->buffer, ' ', s->file_length);
961 /* open_internal()-- Returns a stream structure from an internal file */
964 open_internal (char *base, int length)
968 s = get_mem (sizeof (unix_stream));
969 memset (s, '\0', sizeof (unix_stream));
972 s->buffer_offset = 0;
974 s->logical_offset = 0;
975 s->active = s->file_length = length;
977 s->st.alloc_r_at = (void *) mem_alloc_r_at;
978 s->st.alloc_w_at = (void *) mem_alloc_w_at;
979 s->st.sfree = (void *) mem_sfree;
980 s->st.close = (void *) mem_close;
981 s->st.seek = (void *) mem_seek;
982 s->st.truncate = (void *) mem_truncate;
983 s->st.read = (void *) mem_read;
984 s->st.write = (void *) mem_write;
985 s->st.set = (void *) mem_set;
991 /* fd_to_stream()-- Given an open file descriptor, build a stream
995 fd_to_stream (int fd, int prot)
1000 s = get_mem (sizeof (unix_stream));
1001 memset (s, '\0', sizeof (unix_stream));
1004 s->buffer_offset = 0;
1005 s->physical_offset = 0;
1006 s->logical_offset = 0;
1009 /* Get the current length of the file. */
1011 fstat (fd, &statbuf);
1012 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
1013 s->special_file = !S_ISREG (statbuf.st_mode);
1017 return (stream *) s;
1021 /* Given the Fortran unit number, convert it to a C file descriptor. */
1024 unit_to_fd (int unit)
1029 us = find_unit (unit);
1033 fd = ((unix_stream *) us->s)->fd;
1039 /* unpack_filename()-- Given a fortran string and a pointer to a
1040 * buffer that is PATH_MAX characters, convert the fortran string to a
1041 * C string in the buffer. Returns nonzero if this is not possible. */
1044 unpack_filename (char *cstring, const char *fstring, int len)
1046 len = fstrlen (fstring, len);
1047 if (len >= PATH_MAX)
1050 memmove (cstring, fstring, len);
1051 cstring[len] = '\0';
1057 /* tempfile()-- Generate a temporary filename for a scratch file and
1058 * open it. mkstemp() opens the file for reading and writing, but the
1059 * library mode prevents anything that is not allowed. The descriptor
1060 * is returned, which is -1 on error. The template is pointed to by
1061 * opp->file, which is copied into the unit structure
1062 * and freed later. */
1065 tempfile (st_parameter_open *opp)
1067 const char *tempdir;
1071 tempdir = getenv ("GFORTRAN_TMPDIR");
1072 if (tempdir == NULL)
1073 tempdir = getenv ("TMP");
1074 if (tempdir == NULL)
1075 tempdir = getenv ("TEMP");
1076 if (tempdir == NULL)
1077 tempdir = DEFAULT_TEMPDIR;
1079 template = get_mem (strlen (tempdir) + 20);
1081 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
1085 fd = mkstemp (template);
1087 #else /* HAVE_MKSTEMP */
1089 if (mktemp (template))
1091 #if defined(HAVE_CRLF) && defined(O_BINARY)
1092 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1093 S_IREAD | S_IWRITE);
1095 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1097 while (!(fd == -1 && errno == EEXIST) && mktemp (template));
1101 #endif /* HAVE_MKSTEMP */
1104 free_mem (template);
1107 opp->file = template;
1108 opp->file_len = strlen (template); /* Don't include trailing nul */
1115 /* regular_file()-- Open a regular file.
1116 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1117 * unless an error occurs.
1118 * Returns the descriptor, which is less than zero on error. */
1121 regular_file (st_parameter_open *opp, unit_flags *flags)
1123 char path[PATH_MAX + 1];
1129 if (unpack_filename (path, opp->file, opp->file_len))
1131 errno = ENOENT; /* Fake an OS error */
1137 switch (flags->action)
1147 case ACTION_READWRITE:
1148 case ACTION_UNSPECIFIED:
1153 internal_error (&opp->common, "regular_file(): Bad action");
1156 switch (flags->status)
1159 crflag = O_CREAT | O_EXCL;
1162 case STATUS_OLD: /* open will fail if the file does not exist*/
1166 case STATUS_UNKNOWN:
1167 case STATUS_SCRATCH:
1171 case STATUS_REPLACE:
1172 crflag = O_CREAT | O_TRUNC;
1176 internal_error (&opp->common, "regular_file(): Bad status");
1179 /* rwflag |= O_LARGEFILE; */
1181 #if defined(HAVE_CRLF) && defined(O_BINARY)
1185 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1186 fd = open (path, rwflag | crflag, mode);
1187 if (flags->action != ACTION_UNSPECIFIED)
1192 flags->action = ACTION_READWRITE;
1195 if (errno != EACCES)
1198 /* retry for read-only access */
1200 fd = open (path, rwflag | crflag, mode);
1203 flags->action = ACTION_READ;
1204 return fd; /* success */
1207 if (errno != EACCES)
1208 return fd; /* failure */
1210 /* retry for write-only access */
1212 fd = open (path, rwflag | crflag, mode);
1215 flags->action = ACTION_WRITE;
1216 return fd; /* success */
1218 return fd; /* failure */
1222 /* open_external()-- Open an external file, unix specific version.
1223 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1224 * Returns NULL on operating system error. */
1227 open_external (st_parameter_open *opp, unit_flags *flags)
1231 if (flags->status == STATUS_SCRATCH)
1233 fd = tempfile (opp);
1234 if (flags->action == ACTION_UNSPECIFIED)
1235 flags->action = ACTION_READWRITE;
1237 #if HAVE_UNLINK_OPEN_FILE
1238 /* We can unlink scratch files now and it will go away when closed. */
1245 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1247 fd = regular_file (opp, flags);
1254 switch (flags->action)
1264 case ACTION_READWRITE:
1265 prot = PROT_READ | PROT_WRITE;
1269 internal_error (&opp->common, "open_external(): Bad action");
1272 return fd_to_stream (fd, prot);
1276 /* input_stream()-- Return a stream pointer to the default input stream.
1277 * Called on initialization. */
1282 return fd_to_stream (STDIN_FILENO, PROT_READ);
1286 /* output_stream()-- Return a stream pointer to the default output stream.
1287 * Called on initialization. */
1290 output_stream (void)
1292 return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1296 /* error_stream()-- Return a stream pointer to the default error stream.
1297 * Called on initialization. */
1302 return fd_to_stream (STDERR_FILENO, PROT_WRITE);
1305 /* init_error_stream()-- Return a pointer to the error stream. This
1306 * subroutine is called when the stream is needed, rather than at
1307 * initialization. We want to work even if memory has been seriously
1311 init_error_stream (unix_stream *error)
1313 memset (error, '\0', sizeof (*error));
1315 error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1317 error->st.alloc_w_at = (void *) fd_alloc_w_at;
1318 error->st.sfree = (void *) fd_sfree;
1320 error->unbuffered = 1;
1321 error->buffer = error->small_buffer;
1323 return (stream *) error;
1327 /* compare_file_filename()-- Given an open stream and a fortran string
1328 * that is a filename, figure out if the file is the same as the
1332 compare_file_filename (gfc_unit *u, const char *name, int len)
1334 char path[PATH_MAX + 1];
1336 #ifdef HAVE_WORKING_STAT
1340 if (unpack_filename (path, name, len))
1341 return 0; /* Can't be the same */
1343 /* If the filename doesn't exist, then there is no match with the
1346 if (stat (path, &st1) < 0)
1349 #ifdef HAVE_WORKING_STAT
1350 fstat (((unix_stream *) (u->s))->fd, &st2);
1351 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1353 if (len != u->file_len)
1355 return (memcmp(path, u->file, len) == 0);
1360 #ifdef HAVE_WORKING_STAT
1361 # define FIND_FILE0_DECL struct stat *st
1362 # define FIND_FILE0_ARGS st
1364 # define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
1365 # define FIND_FILE0_ARGS file, file_len
1368 /* find_file0()-- Recursive work function for find_file() */
1371 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1378 #ifdef HAVE_WORKING_STAT
1380 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1381 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1384 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1388 v = find_file0 (u->left, FIND_FILE0_ARGS);
1392 v = find_file0 (u->right, FIND_FILE0_ARGS);
1400 /* find_file()-- Take the current filename and see if there is a unit
1401 * that has the file already open. Returns a pointer to the unit if so. */
1404 find_file (const char *file, gfc_charlen_type file_len)
1406 char path[PATH_MAX + 1];
1410 if (unpack_filename (path, file, file_len))
1413 if (stat (path, &st[0]) < 0)
1416 __gthread_mutex_lock (&unit_lock);
1418 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1422 if (! __gthread_mutex_trylock (&u->lock))
1424 /* assert (u->closed == 0); */
1425 __gthread_mutex_unlock (&unit_lock);
1429 inc_waiting_locked (u);
1431 __gthread_mutex_unlock (&unit_lock);
1434 __gthread_mutex_lock (&u->lock);
1437 __gthread_mutex_lock (&unit_lock);
1438 __gthread_mutex_unlock (&u->lock);
1439 if (predec_waiting_locked (u) == 0)
1444 dec_waiting_unlocked (u);
1450 flush_all_units_1 (gfc_unit *u, int min_unit)
1454 if (u->unit_number > min_unit)
1456 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1460 if (u->unit_number >= min_unit)
1462 if (__gthread_mutex_trylock (&u->lock))
1466 __gthread_mutex_unlock (&u->lock);
1474 flush_all_units (void)
1479 __gthread_mutex_lock (&unit_lock);
1482 u = flush_all_units_1 (unit_root, min_unit);
1484 inc_waiting_locked (u);
1485 __gthread_mutex_unlock (&unit_lock);
1489 __gthread_mutex_lock (&u->lock);
1491 min_unit = u->unit_number + 1;
1496 __gthread_mutex_lock (&unit_lock);
1497 __gthread_mutex_unlock (&u->lock);
1498 (void) predec_waiting_locked (u);
1502 __gthread_mutex_lock (&unit_lock);
1503 __gthread_mutex_unlock (&u->lock);
1504 if (predec_waiting_locked (u) == 0)
1512 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1516 stream_at_bof (stream * s)
1520 if (!is_seekable (s))
1523 us = (unix_stream *) s;
1525 return us->logical_offset == 0;
1529 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1533 stream_at_eof (stream * s)
1537 if (!is_seekable (s))
1540 us = (unix_stream *) s;
1542 return us->logical_offset == us->dirty_offset;
1546 /* delete_file()-- Given a unit structure, delete the file associated
1547 * with the unit. Returns nonzero if something went wrong. */
1550 delete_file (gfc_unit * u)
1552 char path[PATH_MAX + 1];
1554 if (unpack_filename (path, u->file, u->file_len))
1555 { /* Shouldn't be possible */
1560 return unlink (path);
1564 /* file_exists()-- Returns nonzero if the current filename exists on
1568 file_exists (const char *file, gfc_charlen_type file_len)
1570 char path[PATH_MAX + 1];
1571 struct stat statbuf;
1573 if (unpack_filename (path, file, file_len))
1576 if (stat (path, &statbuf) < 0)
1584 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1586 /* inquire_sequential()-- Given a fortran string, determine if the
1587 * file is suitable for sequential access. Returns a C-style
1591 inquire_sequential (const char *string, int len)
1593 char path[PATH_MAX + 1];
1594 struct stat statbuf;
1596 if (string == NULL ||
1597 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1600 if (S_ISREG (statbuf.st_mode) ||
1601 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1604 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1611 /* inquire_direct()-- Given a fortran string, determine if the file is
1612 * suitable for direct access. Returns a C-style string. */
1615 inquire_direct (const char *string, int len)
1617 char path[PATH_MAX + 1];
1618 struct stat statbuf;
1620 if (string == NULL ||
1621 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1624 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1627 if (S_ISDIR (statbuf.st_mode) ||
1628 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1635 /* inquire_formatted()-- Given a fortran string, determine if the file
1636 * is suitable for formatted form. Returns a C-style string. */
1639 inquire_formatted (const char *string, int len)
1641 char path[PATH_MAX + 1];
1642 struct stat statbuf;
1644 if (string == NULL ||
1645 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1648 if (S_ISREG (statbuf.st_mode) ||
1649 S_ISBLK (statbuf.st_mode) ||
1650 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1653 if (S_ISDIR (statbuf.st_mode))
1660 /* inquire_unformatted()-- Given a fortran string, determine if the file
1661 * is suitable for unformatted form. Returns a C-style string. */
1664 inquire_unformatted (const char *string, int len)
1666 return inquire_formatted (string, len);
1670 /* inquire_access()-- Given a fortran string, determine if the file is
1671 * suitable for access. */
1674 inquire_access (const char *string, int len, int mode)
1676 char path[PATH_MAX + 1];
1678 if (string == NULL || unpack_filename (path, string, len) ||
1679 access (path, mode) < 0)
1686 /* inquire_read()-- Given a fortran string, determine if the file is
1687 * suitable for READ access. */
1690 inquire_read (const char *string, int len)
1692 return inquire_access (string, len, R_OK);
1696 /* inquire_write()-- Given a fortran string, determine if the file is
1697 * suitable for READ access. */
1700 inquire_write (const char *string, int len)
1702 return inquire_access (string, len, W_OK);
1706 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1707 * suitable for read and write access. */
1710 inquire_readwrite (const char *string, int len)
1712 return inquire_access (string, len, R_OK | W_OK);
1716 /* file_length()-- Return the file length in bytes, -1 if unknown */
1719 file_length (stream * s)
1721 return ((unix_stream *) s)->file_length;
1725 /* file_position()-- Return the current position of the file */
1728 file_position (stream * s)
1730 return ((unix_stream *) s)->logical_offset;
1734 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1738 is_seekable (stream * s)
1740 /* By convention, if file_length == -1, the file is not
1742 return ((unix_stream *) s)->file_length!=-1;
1748 return fd_flush( (unix_stream *) s);
1752 stream_isatty (stream *s)
1754 return isatty (((unix_stream *) s)->fd);
1758 stream_ttyname (stream *s)
1761 return ttyname (((unix_stream *) s)->fd);
1768 stream_offset (stream *s)
1770 return (((unix_stream *) s)->logical_offset);
1774 /* How files are stored: This is an operating-system specific issue,
1775 and therefore belongs here. There are three cases to consider.
1778 Records are written as block of bytes corresponding to the record
1779 length of the file. This goes for both formatted and unformatted
1780 records. Positioning is done explicitly for each data transfer,
1781 so positioning is not much of an issue.
1783 Sequential Formatted:
1784 Records are separated by newline characters. The newline character
1785 is prohibited from appearing in a string. If it does, this will be
1786 messed up on the next read. End of file is also the end of a record.
1788 Sequential Unformatted:
1789 In this case, we are merely copying bytes to and from main storage,
1790 yet we need to keep track of varying record lengths. We adopt
1791 the solution used by f2c. Each record contains a pair of length
1794 Length of record n in bytes
1796 Length of record n in bytes
1798 Length of record n+1 in bytes
1800 Length of record n+1 in bytes
1802 The length is stored at the end of a record to allow backspacing to the
1803 previous record. Between data transfer statements, the file pointer
1804 is left pointing to the first length of the current record.
1806 ENDFILE records are never explicitly stored.