1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 /* Unix stream I/O module */
46 /* For mingw, we don't identify files by their inode number, but by a
47 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
48 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
50 #define WIN32_LEAN_AND_MEAN
54 id_from_handle (HANDLE hFile)
56 BY_HANDLE_FILE_INFORMATION FileInformation;
58 if (hFile == INVALID_HANDLE_VALUE)
61 memset (&FileInformation, 0, sizeof(FileInformation));
62 if (!GetFileInformationByHandle (hFile, &FileInformation))
65 return ((uint64_t) FileInformation.nFileIndexLow)
66 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
71 id_from_path (const char *path)
76 if (!path || !*path || access (path, F_OK))
79 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
80 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
82 res = id_from_handle (hFile);
89 id_from_fd (const int fd)
91 return id_from_handle ((HANDLE) _get_osfhandle (fd));
99 #define SSIZE_MAX SHRT_MAX
103 #define PATH_MAX 1024
114 /* These flags aren't defined on all targets (mingw32), so provide them
133 /* Unix stream I/O module */
135 #define BUFFER_SIZE 8192
142 gfc_offset buffer_offset; /* File offset of the start of the buffer */
143 gfc_offset physical_offset; /* Current physical file offset */
144 gfc_offset logical_offset; /* Current logical file offset */
145 gfc_offset dirty_offset; /* Start of modified bytes in buffer */
146 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
148 int len; /* Physical length of the current buffer */
149 int active; /* Length of valid bytes in the buffer */
152 int ndirty; /* Dirty bytes starting at dirty_offset */
154 int special_file; /* =1 if the fd refers to a special file */
156 int unbuffered; /* =1 if the stream is not buffered */
159 char small_buffer[BUFFER_SIZE];
164 /* Stream structure for internal files. Fields must be kept in sync
165 with unix_stream above, except for the buffer. For internal files
166 we point the buffer pointer directly at the destination memory. */
173 gfc_offset buffer_offset; /* File offset of the start of the buffer */
174 gfc_offset physical_offset; /* Current physical file offset */
175 gfc_offset logical_offset; /* Current logical file offset */
176 gfc_offset dirty_offset; /* Start of modified bytes in buffer */
177 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
179 int len; /* Physical length of the current buffer */
180 int active; /* Length of valid bytes in the buffer */
183 int ndirty; /* Dirty bytes starting at dirty_offset */
185 int special_file; /* =1 if the fd refers to a special file */
187 int unbuffered; /* =1 if the stream is not buffered */
193 /* This implementation of stream I/O is based on the paper:
195 * "Exploiting the advantages of mapped files for stream I/O",
196 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
197 * USENIX conference", p. 27-42.
199 * It differs in a number of ways from the version described in the
200 * paper. First of all, threads are not an issue during I/O and we
201 * also don't have to worry about having multiple regions, since
202 * fortran's I/O model only allows you to be one place at a time.
204 * On the other hand, we have to be able to writing at the end of a
205 * stream, read from the start of a stream or read and write blocks of
206 * bytes from an arbitrary position. After opening a file, a pointer
207 * to a stream structure is returned, which is used to handle file
208 * accesses until the file is closed.
210 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
211 * pointer to a block of memory that mirror the file at position
212 * 'where' that is 'len' bytes long. The len integer is updated to
213 * reflect how many bytes were actually read. The only reason for a
214 * short read is end of file. The file pointer is updated. The
215 * pointer is valid until the next call to salloc_*.
217 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
218 * a pointer to a block of memory that is updated to reflect the state
219 * of the file. The length of the buffer is always equal to that
220 * requested. The buffer must be completely set by the caller. When
221 * data has been written, the sfree() function must be called to
222 * indicate that the caller is done writing data to the buffer. This
223 * may or may not cause a physical write.
225 * Short forms of these are salloc_r() and salloc_w() which drop the
226 * 'where' parameter and use the current file pointer. */
229 /*move_pos_offset()-- Move the record pointer right or left
230 *relative to current position */
233 move_pos_offset (stream* st, int pos_off)
235 unix_stream * str = (unix_stream*)st;
238 str->logical_offset += pos_off;
240 if (str->dirty_offset + str->ndirty > str->logical_offset)
242 if (str->ndirty + pos_off > 0)
243 str->ndirty += pos_off;
246 str->dirty_offset += pos_off + pos_off;
257 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
258 * standard descriptors, returning a non-standard descriptor. If the
259 * user specifies that system errors should go to standard output,
260 * then closes standard output, we don't want the system errors to a
261 * file that has been given file descriptor 1 or 0. We want to send
262 * the error to the invalid descriptor. */
268 int input, output, error;
270 input = output = error = 0;
272 /* Unix allocates the lowest descriptors first, so a loop is not
273 required, but this order is. */
274 if (fd == STDIN_FILENO)
279 if (fd == STDOUT_FILENO)
284 if (fd == STDERR_FILENO)
291 close (STDIN_FILENO);
293 close (STDOUT_FILENO);
295 close (STDERR_FILENO);
302 is_preconnected (stream * s)
306 fd = ((unix_stream *) s)->fd;
307 if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO)
313 /* If the stream corresponds to a preconnected unit, we flush the
314 corresponding C stream. This is bugware for mixed C-Fortran codes
315 where the C code doesn't flush I/O before returning. */
317 flush_if_preconnected (stream * s)
321 fd = ((unix_stream *) s)->fd;
322 if (fd == STDIN_FILENO)
324 else if (fd == STDOUT_FILENO)
326 else if (fd == STDERR_FILENO)
331 /* Reset a stream after reading/writing. Assumes that the buffers have
335 reset_stream (unix_stream * s, size_t bytes_rw)
337 s->physical_offset += bytes_rw;
338 s->logical_offset = s->physical_offset;
339 if (s->file_length != -1 && s->physical_offset > s->file_length)
340 s->file_length = s->physical_offset;
344 /* Read bytes into a buffer, allowing for short reads. If the nbytes
345 * argument is less on return than on entry, it is because we've hit
346 * the end of file. */
349 do_read (unix_stream * s, void * buf, size_t * nbytes)
357 bytes_left = *nbytes;
358 buf_st = (char *) buf;
360 /* We must read in a loop since some systems don't restart system
361 calls in case of a signal. */
362 while (bytes_left > 0)
364 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
365 so we must read in chunks smaller than SSIZE_MAX. */
366 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
367 trans = read (s->fd, buf_st, trans);
378 else if (trans == 0) /* We hit EOF. */
384 *nbytes -= bytes_left;
389 /* Write a buffer to a stream, allowing for short writes. */
392 do_write (unix_stream * s, const void * buf, size_t * nbytes)
400 bytes_left = *nbytes;
401 buf_st = (char *) buf;
403 /* We must write in a loop since some systems don't restart system
404 calls in case of a signal. */
405 while (bytes_left > 0)
407 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
408 so we must write in chunks smaller than SSIZE_MAX. */
409 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
410 trans = write (s->fd, buf_st, trans);
425 *nbytes -= bytes_left;
430 /* get_oserror()-- Get the most recent operating system error. For
431 * unix, this is errno. */
436 return strerror (errno);
440 /*********************************************************************
441 File descriptor stream functions
442 *********************************************************************/
445 /* fd_flush()-- Write bytes that need to be written */
448 fd_flush (unix_stream * s)
455 if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
456 lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
459 writelen = s->ndirty;
460 if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
464 s->physical_offset = s->dirty_offset + writelen;
466 /* don't increment file_length if the file is non-seekable */
467 if (s->file_length != -1 && s->physical_offset > s->file_length)
468 s->file_length = s->physical_offset;
470 s->ndirty -= writelen;
478 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
479 * satisfied. This subroutine gets the buffer ready for whatever is
483 fd_alloc (unix_stream * s, gfc_offset where,
484 int *len __attribute__ ((unused)))
489 if (*len <= BUFFER_SIZE)
491 new_buffer = s->small_buffer;
492 read_len = BUFFER_SIZE;
496 new_buffer = get_mem (*len);
500 /* Salvage bytes currently within the buffer. This is important for
501 * devices that cannot seek. */
503 if (s->buffer != NULL && s->buffer_offset <= where &&
504 where <= s->buffer_offset + s->active)
507 n = s->active - (where - s->buffer_offset);
508 memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
513 { /* new buffer starts off empty */
517 s->buffer_offset = where;
519 /* free the old buffer if necessary */
521 if (s->buffer != NULL && s->buffer != s->small_buffer)
522 free_mem (s->buffer);
524 s->buffer = new_buffer;
529 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
530 * we've already buffered the data or we need to load it. Returns
531 * NULL on I/O error. */
534 fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
539 where = s->logical_offset;
541 if (s->buffer != NULL && s->buffer_offset <= where &&
542 where + *len <= s->buffer_offset + s->active)
545 /* Return a position within the current buffer */
547 s->logical_offset = where + *len;
548 return s->buffer + where - s->buffer_offset;
551 fd_alloc (s, where, len);
553 m = where + s->active;
555 if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
558 /* do_read() hangs on read from terminals for *BSD-systems. Only
559 use read() in that case. */
565 n = read (s->fd, s->buffer + s->active, s->len - s->active);
569 s->physical_offset = m + n;
576 n = s->len - s->active;
577 if (do_read (s, s->buffer + s->active, &n) != 0)
580 s->physical_offset = m + n;
584 if (s->active < *len)
585 *len = s->active; /* Bytes actually available */
587 s->logical_offset = where + *len;
593 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
594 * we've already buffered the data or we need to load it. */
597 fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
602 where = s->logical_offset;
604 if (s->buffer == NULL || s->buffer_offset > where ||
605 where + *len > s->buffer_offset + s->len)
608 if (fd_flush (s) == FAILURE)
610 fd_alloc (s, where, len);
613 /* Return a position within the current buffer */
615 || where > s->dirty_offset + s->ndirty
616 || s->dirty_offset > where + *len)
617 { /* Discontiguous blocks, start with a clean buffer. */
618 /* Flush the buffer. */
621 s->dirty_offset = where;
626 gfc_offset start; /* Merge with the existing data. */
627 if (where < s->dirty_offset)
630 start = s->dirty_offset;
631 if (where + *len > s->dirty_offset + s->ndirty)
632 s->ndirty = where + *len - start;
634 s->ndirty = s->dirty_offset + s->ndirty - start;
635 s->dirty_offset = start;
638 s->logical_offset = where + *len;
640 /* Don't increment file_length if the file is non-seekable. */
642 if (s->file_length != -1 && s->logical_offset > s->file_length)
643 s->file_length = s->logical_offset;
645 n = s->logical_offset - s->buffer_offset;
649 return s->buffer + where - s->buffer_offset;
654 fd_sfree (unix_stream * s)
656 if (s->ndirty != 0 &&
657 (s->buffer != s->small_buffer || options.all_unbuffered ||
666 fd_seek (unix_stream * s, gfc_offset offset)
669 if (s->file_length == -1)
672 if (s->physical_offset == offset) /* Are we lucky and avoid syscall? */
674 s->logical_offset = offset;
678 if (lseek (s->fd, offset, SEEK_SET) >= 0)
680 s->physical_offset = s->logical_offset = offset;
689 /* truncate_file()-- Given a unit, truncate the file at the current
690 * position. Sets the physical location to the new end of the file.
691 * Returns nonzero on error. */
694 fd_truncate (unix_stream * s)
696 /* Non-seekable files, like terminals and fifo's fail the lseek so just
697 return success, there is nothing to truncate. If its not a pipe there
698 is a real problem. */
699 if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
707 /* Using ftruncate on a seekable special file (like /dev/null)
708 is undefined, so we treat it as if the ftruncate succeeded. */
711 #ifdef HAVE_FTRUNCATE
712 ftruncate (s->fd, s->logical_offset) != 0
713 #elif defined HAVE_CHSIZE
714 chsize (s->fd, s->logical_offset) != 0
716 /* If we have neither, always fail and exit, noisily. */
717 runtime_error ("required ftruncate or chsize support not present"), 1
721 /* The truncation failed and we need to handle this gracefully.
722 The file length remains the same, but the file-descriptor
723 offset needs adjustment per the successful lseek above.
724 (Similarly, the contents of the buffer isn't valid anymore.)
725 A ftruncate call does not affect the physical (file-descriptor)
726 offset, according to the ftruncate manual, so neither should a
728 s->physical_offset = s->logical_offset;
733 s->physical_offset = s->file_length = s->logical_offset;
739 /* Similar to memset(), but operating on a stream instead of a string.
740 Takes care of not using too much memory. */
743 fd_sset (unix_stream * s, int c, size_t n)
751 while (bytes_left > 0)
753 /* memset() in chunks of BUFFER_SIZE. */
754 trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
756 p = fd_alloc_w_at (s, &trans, -1);
758 memset (p, c, trans);
769 /* Stream read function. Avoids using a buffer for big reads. The
770 interface is like POSIX read(), but the nbytes argument is a
771 pointer; on return it contains the number of bytes written. The
772 function return value is the status indicator (0 for success). */
775 fd_read (unix_stream * s, void * buf, size_t * nbytes)
780 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
783 p = fd_alloc_r_at (s, &tmp, -1);
787 memcpy (buf, p, *nbytes);
797 /* If the request is bigger than BUFFER_SIZE we flush the buffers
798 and read directly. */
799 if (fd_flush (s) == FAILURE)
805 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
811 status = do_read (s, buf, nbytes);
812 reset_stream (s, *nbytes);
817 /* Stream write function. Avoids using a buffer for big writes. The
818 interface is like POSIX write(), but the nbytes argument is a
819 pointer; on return it contains the number of bytes written. The
820 function return value is the status indicator (0 for success). */
823 fd_write (unix_stream * s, const void * buf, size_t * nbytes)
828 if (*nbytes < BUFFER_SIZE && !s->unbuffered)
831 p = fd_alloc_w_at (s, &tmp, -1);
835 memcpy (p, buf, *nbytes);
845 /* If the request is bigger than BUFFER_SIZE we flush the buffers
846 and write directly. */
847 if (fd_flush (s) == FAILURE)
853 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
859 status = do_write (s, buf, nbytes);
860 reset_stream (s, *nbytes);
866 fd_close (unix_stream * s)
868 if (fd_flush (s) == FAILURE)
871 if (s->buffer != NULL && s->buffer != s->small_buffer)
872 free_mem (s->buffer);
874 if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO)
876 if (close (s->fd) < 0)
887 fd_open (unix_stream * s)
892 s->st.alloc_r_at = (void *) fd_alloc_r_at;
893 s->st.alloc_w_at = (void *) fd_alloc_w_at;
894 s->st.sfree = (void *) fd_sfree;
895 s->st.close = (void *) fd_close;
896 s->st.seek = (void *) fd_seek;
897 s->st.trunc = (void *) fd_truncate;
898 s->st.read = (void *) fd_read;
899 s->st.write = (void *) fd_write;
900 s->st.set = (void *) fd_sset;
908 /*********************************************************************
909 memory stream functions - These are used for internal files
911 The idea here is that a single stream structure is created and all
912 requests must be satisfied from it. The location and size of the
913 buffer is the character variable supplied to the READ or WRITE
916 *********************************************************************/
920 mem_alloc_r_at (int_stream * s, int *len, gfc_offset where)
925 where = s->logical_offset;
927 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
930 s->logical_offset = where + *len;
932 n = s->buffer_offset + s->active - where;
936 return s->buffer + (where - s->buffer_offset);
941 mem_alloc_w_at (int_stream * s, int *len, gfc_offset where)
945 assert (*len >= 0); /* Negative values not allowed. */
948 where = s->logical_offset;
952 if (where < s->buffer_offset)
955 if (m > s->file_length)
958 s->logical_offset = m;
960 return s->buffer + (where - s->buffer_offset);
964 /* Stream read function for internal units. This is not actually used
965 at the moment, as all internal IO is formatted and the formatted IO
966 routines use mem_alloc_r_at. */
969 mem_read (int_stream * s, void * buf, size_t * nbytes)
975 p = mem_alloc_r_at (s, &tmp, -1);
979 memcpy (buf, p, *nbytes);
990 /* Stream write function for internal units. This is not actually used
991 at the moment, as all internal IO is formatted and the formatted IO
992 routines use mem_alloc_w_at. */
995 mem_write (int_stream * s, const void * buf, size_t * nbytes)
1003 p = mem_alloc_w_at (s, &tmp, -1);
1007 memcpy (p, buf, *nbytes);
1019 mem_seek (int_stream * s, gfc_offset offset)
1021 if (offset > s->file_length)
1027 s->logical_offset = offset;
1033 mem_set (int_stream * s, int c, size_t n)
1040 p = mem_alloc_w_at (s, &len, -1);
1052 mem_truncate (int_stream * s __attribute__ ((unused)))
1059 mem_close (int_stream * s)
1069 mem_sfree (int_stream * s __attribute__ ((unused)))
1076 /*********************************************************************
1077 Public functions -- A reimplementation of this module needs to
1078 define functional equivalents of the following.
1079 *********************************************************************/
1081 /* empty_internal_buffer()-- Zero the buffer of Internal file */
1084 empty_internal_buffer(stream *strm)
1086 int_stream * s = (int_stream *) strm;
1087 memset(s->buffer, ' ', s->file_length);
1090 /* open_internal()-- Returns a stream structure from an internal file */
1093 open_internal (char *base, int length, gfc_offset offset)
1097 s = get_mem (sizeof (int_stream));
1098 memset (s, '\0', sizeof (int_stream));
1101 s->buffer_offset = offset;
1103 s->logical_offset = 0;
1104 s->active = s->file_length = length;
1106 s->st.alloc_r_at = (void *) mem_alloc_r_at;
1107 s->st.alloc_w_at = (void *) mem_alloc_w_at;
1108 s->st.sfree = (void *) mem_sfree;
1109 s->st.close = (void *) mem_close;
1110 s->st.seek = (void *) mem_seek;
1111 s->st.trunc = (void *) mem_truncate;
1112 s->st.read = (void *) mem_read;
1113 s->st.write = (void *) mem_write;
1114 s->st.set = (void *) mem_set;
1116 return (stream *) s;
1120 /* fd_to_stream()-- Given an open file descriptor, build a stream
1124 fd_to_stream (int fd, int prot)
1126 struct stat statbuf;
1129 s = get_mem (sizeof (unix_stream));
1130 memset (s, '\0', sizeof (unix_stream));
1133 s->buffer_offset = 0;
1134 s->physical_offset = 0;
1135 s->logical_offset = 0;
1138 /* Get the current length of the file. */
1140 fstat (fd, &statbuf);
1142 if (lseek (fd, 0, SEEK_CUR) == (off_t) -1)
1143 s->file_length = -1;
1145 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
1147 s->special_file = !S_ISREG (statbuf.st_mode);
1151 return (stream *) s;
1155 /* Given the Fortran unit number, convert it to a C file descriptor. */
1158 unit_to_fd (int unit)
1163 us = find_unit (unit);
1167 fd = ((unix_stream *) us->s)->fd;
1173 /* unpack_filename()-- Given a fortran string and a pointer to a
1174 * buffer that is PATH_MAX characters, convert the fortran string to a
1175 * C string in the buffer. Returns nonzero if this is not possible. */
1178 unpack_filename (char *cstring, const char *fstring, int len)
1180 len = fstrlen (fstring, len);
1181 if (len >= PATH_MAX)
1184 memmove (cstring, fstring, len);
1185 cstring[len] = '\0';
1191 /* tempfile()-- Generate a temporary filename for a scratch file and
1192 * open it. mkstemp() opens the file for reading and writing, but the
1193 * library mode prevents anything that is not allowed. The descriptor
1194 * is returned, which is -1 on error. The template is pointed to by
1195 * opp->file, which is copied into the unit structure
1196 * and freed later. */
1199 tempfile (st_parameter_open *opp)
1201 const char *tempdir;
1205 tempdir = getenv ("GFORTRAN_TMPDIR");
1206 if (tempdir == NULL)
1207 tempdir = getenv ("TMP");
1208 if (tempdir == NULL)
1209 tempdir = getenv ("TEMP");
1210 if (tempdir == NULL)
1211 tempdir = DEFAULT_TEMPDIR;
1213 template = get_mem (strlen (tempdir) + 20);
1215 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
1219 fd = mkstemp (template);
1221 #else /* HAVE_MKSTEMP */
1223 if (mktemp (template))
1225 #if defined(HAVE_CRLF) && defined(O_BINARY)
1226 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1227 S_IREAD | S_IWRITE);
1229 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1231 while (!(fd == -1 && errno == EEXIST) && mktemp (template));
1235 #endif /* HAVE_MKSTEMP */
1238 free_mem (template);
1241 opp->file = template;
1242 opp->file_len = strlen (template); /* Don't include trailing nul */
1249 /* regular_file()-- Open a regular file.
1250 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1251 * unless an error occurs.
1252 * Returns the descriptor, which is less than zero on error. */
1255 regular_file (st_parameter_open *opp, unit_flags *flags)
1257 char path[PATH_MAX + 1];
1263 if (unpack_filename (path, opp->file, opp->file_len))
1265 errno = ENOENT; /* Fake an OS error */
1271 switch (flags->action)
1281 case ACTION_READWRITE:
1282 case ACTION_UNSPECIFIED:
1287 internal_error (&opp->common, "regular_file(): Bad action");
1290 switch (flags->status)
1293 crflag = O_CREAT | O_EXCL;
1296 case STATUS_OLD: /* open will fail if the file does not exist*/
1300 case STATUS_UNKNOWN:
1301 case STATUS_SCRATCH:
1305 case STATUS_REPLACE:
1306 crflag = O_CREAT | O_TRUNC;
1310 internal_error (&opp->common, "regular_file(): Bad status");
1313 /* rwflag |= O_LARGEFILE; */
1315 #if defined(HAVE_CRLF) && defined(O_BINARY)
1319 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1320 fd = open (path, rwflag | crflag, mode);
1321 if (flags->action != ACTION_UNSPECIFIED)
1326 flags->action = ACTION_READWRITE;
1329 if (errno != EACCES && errno != EROFS)
1332 /* retry for read-only access */
1334 fd = open (path, rwflag | crflag, mode);
1337 flags->action = ACTION_READ;
1338 return fd; /* success */
1341 if (errno != EACCES)
1342 return fd; /* failure */
1344 /* retry for write-only access */
1346 fd = open (path, rwflag | crflag, mode);
1349 flags->action = ACTION_WRITE;
1350 return fd; /* success */
1352 return fd; /* failure */
1356 /* open_external()-- Open an external file, unix specific version.
1357 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1358 * Returns NULL on operating system error. */
1361 open_external (st_parameter_open *opp, unit_flags *flags)
1365 if (flags->status == STATUS_SCRATCH)
1367 fd = tempfile (opp);
1368 if (flags->action == ACTION_UNSPECIFIED)
1369 flags->action = ACTION_READWRITE;
1371 #if HAVE_UNLINK_OPEN_FILE
1372 /* We can unlink scratch files now and it will go away when closed. */
1379 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1381 fd = regular_file (opp, flags);
1388 switch (flags->action)
1398 case ACTION_READWRITE:
1399 prot = PROT_READ | PROT_WRITE;
1403 internal_error (&opp->common, "open_external(): Bad action");
1406 return fd_to_stream (fd, prot);
1410 /* input_stream()-- Return a stream pointer to the default input stream.
1411 * Called on initialization. */
1416 return fd_to_stream (STDIN_FILENO, PROT_READ);
1420 /* output_stream()-- Return a stream pointer to the default output stream.
1421 * Called on initialization. */
1424 output_stream (void)
1428 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1429 setmode (STDOUT_FILENO, O_BINARY);
1432 s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1433 if (options.unbuffered_preconnected)
1434 ((unix_stream *) s)->unbuffered = 1;
1439 /* error_stream()-- Return a stream pointer to the default error stream.
1440 * Called on initialization. */
1447 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1448 setmode (STDERR_FILENO, O_BINARY);
1451 s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1452 if (options.unbuffered_preconnected)
1453 ((unix_stream *) s)->unbuffered = 1;
1458 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1459 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1460 is big enough to completely fill a 80x25 terminal, so it shuld be
1461 OK. We use a direct write() because it is simpler and least likely
1462 to be clobbered by memory corruption. Writing an error message
1463 longer than that is an error. */
1465 #define ST_VPRINTF_SIZE 2048
1468 st_vprintf (const char *format, va_list ap)
1470 static char buffer[ST_VPRINTF_SIZE];
1474 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1475 #ifdef HAVE_VSNPRINTF
1476 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1478 written = vsprintf(buffer, format, ap);
1480 if (written >= ST_VPRINTF_SIZE-1)
1482 /* The error message was longer than our buffer. Ouch. Because
1483 we may have messed up things badly, report the error and
1485 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1486 write (fd, buffer, ST_VPRINTF_SIZE-1);
1487 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1489 #undef ERROR_MESSAGE
1494 written = write (fd, buffer, written);
1498 /* st_printf()-- printf() function for error output. This just calls
1499 st_vprintf() to do the actual work. */
1502 st_printf (const char *format, ...)
1506 va_start (ap, format);
1507 written = st_vprintf(format, ap);
1513 /* compare_file_filename()-- Given an open stream and a fortran string
1514 * that is a filename, figure out if the file is the same as the
1518 compare_file_filename (gfc_unit *u, const char *name, int len)
1520 char path[PATH_MAX + 1];
1522 #ifdef HAVE_WORKING_STAT
1530 if (unpack_filename (path, name, len))
1531 return 0; /* Can't be the same */
1533 /* If the filename doesn't exist, then there is no match with the
1536 if (stat (path, &st1) < 0)
1539 #ifdef HAVE_WORKING_STAT
1540 fstat (((unix_stream *) (u->s))->fd, &st2);
1541 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1545 /* We try to match files by a unique ID. On some filesystems (network
1546 fs and FAT), we can't generate this unique ID, and will simply compare
1548 id1 = id_from_path (path);
1549 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1551 return (id1 == id2);
1554 if (len != u->file_len)
1556 return (memcmp(path, u->file, len) == 0);
1561 #ifdef HAVE_WORKING_STAT
1562 # define FIND_FILE0_DECL struct stat *st
1563 # define FIND_FILE0_ARGS st
1565 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1566 # define FIND_FILE0_ARGS id, file, file_len
1569 /* find_file0()-- Recursive work function for find_file() */
1572 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1575 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1582 #ifdef HAVE_WORKING_STAT
1584 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1585 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1589 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1596 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1600 v = find_file0 (u->left, FIND_FILE0_ARGS);
1604 v = find_file0 (u->right, FIND_FILE0_ARGS);
1612 /* find_file()-- Take the current filename and see if there is a unit
1613 * that has the file already open. Returns a pointer to the unit if so. */
1616 find_file (const char *file, gfc_charlen_type file_len)
1618 char path[PATH_MAX + 1];
1623 if (unpack_filename (path, file, file_len))
1626 if (stat (path, &st[0]) < 0)
1629 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1630 id = id_from_path (path);
1635 __gthread_mutex_lock (&unit_lock);
1637 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1641 if (! __gthread_mutex_trylock (&u->lock))
1643 /* assert (u->closed == 0); */
1644 __gthread_mutex_unlock (&unit_lock);
1648 inc_waiting_locked (u);
1650 __gthread_mutex_unlock (&unit_lock);
1653 __gthread_mutex_lock (&u->lock);
1656 __gthread_mutex_lock (&unit_lock);
1657 __gthread_mutex_unlock (&u->lock);
1658 if (predec_waiting_locked (u) == 0)
1663 dec_waiting_unlocked (u);
1669 flush_all_units_1 (gfc_unit *u, int min_unit)
1673 if (u->unit_number > min_unit)
1675 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1679 if (u->unit_number >= min_unit)
1681 if (__gthread_mutex_trylock (&u->lock))
1685 __gthread_mutex_unlock (&u->lock);
1693 flush_all_units (void)
1698 __gthread_mutex_lock (&unit_lock);
1701 u = flush_all_units_1 (unit_root, min_unit);
1703 inc_waiting_locked (u);
1704 __gthread_mutex_unlock (&unit_lock);
1708 __gthread_mutex_lock (&u->lock);
1710 min_unit = u->unit_number + 1;
1715 __gthread_mutex_lock (&unit_lock);
1716 __gthread_mutex_unlock (&u->lock);
1717 (void) predec_waiting_locked (u);
1721 __gthread_mutex_lock (&unit_lock);
1722 __gthread_mutex_unlock (&u->lock);
1723 if (predec_waiting_locked (u) == 0)
1731 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1735 stream_at_bof (stream * s)
1739 if (!is_seekable (s))
1742 us = (unix_stream *) s;
1744 return us->logical_offset == 0;
1748 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1752 stream_at_eof (stream * s)
1756 if (!is_seekable (s))
1759 us = (unix_stream *) s;
1761 return us->logical_offset == us->dirty_offset;
1765 /* delete_file()-- Given a unit structure, delete the file associated
1766 * with the unit. Returns nonzero if something went wrong. */
1769 delete_file (gfc_unit * u)
1771 char path[PATH_MAX + 1];
1773 if (unpack_filename (path, u->file, u->file_len))
1774 { /* Shouldn't be possible */
1779 return unlink (path);
1783 /* file_exists()-- Returns nonzero if the current filename exists on
1787 file_exists (const char *file, gfc_charlen_type file_len)
1789 char path[PATH_MAX + 1];
1790 struct stat statbuf;
1792 if (unpack_filename (path, file, file_len))
1795 if (stat (path, &statbuf) < 0)
1803 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1805 /* inquire_sequential()-- Given a fortran string, determine if the
1806 * file is suitable for sequential access. Returns a C-style
1810 inquire_sequential (const char *string, int len)
1812 char path[PATH_MAX + 1];
1813 struct stat statbuf;
1815 if (string == NULL ||
1816 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1819 if (S_ISREG (statbuf.st_mode) ||
1820 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1823 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1830 /* inquire_direct()-- Given a fortran string, determine if the file is
1831 * suitable for direct access. Returns a C-style string. */
1834 inquire_direct (const char *string, int len)
1836 char path[PATH_MAX + 1];
1837 struct stat statbuf;
1839 if (string == NULL ||
1840 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1843 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1846 if (S_ISDIR (statbuf.st_mode) ||
1847 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1854 /* inquire_formatted()-- Given a fortran string, determine if the file
1855 * is suitable for formatted form. Returns a C-style string. */
1858 inquire_formatted (const char *string, int len)
1860 char path[PATH_MAX + 1];
1861 struct stat statbuf;
1863 if (string == NULL ||
1864 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1867 if (S_ISREG (statbuf.st_mode) ||
1868 S_ISBLK (statbuf.st_mode) ||
1869 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1872 if (S_ISDIR (statbuf.st_mode))
1879 /* inquire_unformatted()-- Given a fortran string, determine if the file
1880 * is suitable for unformatted form. Returns a C-style string. */
1883 inquire_unformatted (const char *string, int len)
1885 return inquire_formatted (string, len);
1899 /* Fallback implementation of access() on systems that don't have it.
1900 Only modes R_OK and W_OK are used in this file. */
1903 fallback_access (const char *path, int mode)
1905 if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1908 if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1915 #define access fallback_access
1919 /* inquire_access()-- Given a fortran string, determine if the file is
1920 * suitable for access. */
1923 inquire_access (const char *string, int len, int mode)
1925 char path[PATH_MAX + 1];
1927 if (string == NULL || unpack_filename (path, string, len) ||
1928 access (path, mode) < 0)
1935 /* inquire_read()-- Given a fortran string, determine if the file is
1936 * suitable for READ access. */
1939 inquire_read (const char *string, int len)
1941 return inquire_access (string, len, R_OK);
1945 /* inquire_write()-- Given a fortran string, determine if the file is
1946 * suitable for READ access. */
1949 inquire_write (const char *string, int len)
1951 return inquire_access (string, len, W_OK);
1955 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1956 * suitable for read and write access. */
1959 inquire_readwrite (const char *string, int len)
1961 return inquire_access (string, len, R_OK | W_OK);
1965 /* file_length()-- Return the file length in bytes, -1 if unknown */
1968 file_length (stream * s)
1970 return ((unix_stream *) s)->file_length;
1974 /* file_position()-- Return the current position of the file */
1977 file_position (stream *s)
1979 return ((unix_stream *) s)->logical_offset;
1983 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1987 is_seekable (stream *s)
1989 /* By convention, if file_length == -1, the file is not
1991 return ((unix_stream *) s)->file_length!=-1;
1995 /* is_special()-- Return nonzero if the stream is not a regular file. */
1998 is_special (stream *s)
2000 return ((unix_stream *) s)->special_file;
2007 return fd_flush( (unix_stream *) s);
2011 stream_isatty (stream *s)
2013 return isatty (((unix_stream *) s)->fd);
2017 stream_ttyname (stream *s __attribute__ ((unused)))
2020 return ttyname (((unix_stream *) s)->fd);
2027 stream_offset (stream *s)
2029 return (((unix_stream *) s)->logical_offset);
2033 /* How files are stored: This is an operating-system specific issue,
2034 and therefore belongs here. There are three cases to consider.
2037 Records are written as block of bytes corresponding to the record
2038 length of the file. This goes for both formatted and unformatted
2039 records. Positioning is done explicitly for each data transfer,
2040 so positioning is not much of an issue.
2042 Sequential Formatted:
2043 Records are separated by newline characters. The newline character
2044 is prohibited from appearing in a string. If it does, this will be
2045 messed up on the next read. End of file is also the end of a record.
2047 Sequential Unformatted:
2048 In this case, we are merely copying bytes to and from main storage,
2049 yet we need to keep track of varying record lengths. We adopt
2050 the solution used by f2c. Each record contains a pair of length
2053 Length of record n in bytes
2055 Length of record n in bytes
2057 Length of record n+1 in bytes
2059 Length of record n+1 in bytes
2061 The length is stored at the end of a record to allow backspacing to the
2062 previous record. Between data transfer statements, the file pointer
2063 is left pointing to the first length of the current record.
2065 ENDFILE records are never explicitly stored.