1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
32 /* Unix stream I/O module */
47 /* For mingw, we don't identify files by their inode number, but by a
48 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
49 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
51 #define WIN32_LEAN_AND_MEAN
55 id_from_handle (HANDLE hFile)
57 BY_HANDLE_FILE_INFORMATION FileInformation;
59 if (hFile == INVALID_HANDLE_VALUE)
62 memset (&FileInformation, 0, sizeof(FileInformation));
63 if (!GetFileInformationByHandle (hFile, &FileInformation))
66 return ((uint64_t) FileInformation.nFileIndexLow)
67 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
72 id_from_path (const char *path)
77 if (!path || !*path || access (path, F_OK))
80 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
81 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
83 res = id_from_handle (hFile);
90 id_from_fd (const int fd)
92 return id_from_handle ((HANDLE) _get_osfhandle (fd));
98 #define SSIZE_MAX SHRT_MAX
102 #define PATH_MAX 1024
113 /* These flags aren't defined on all targets (mingw32), so provide them
132 /* Unix stream I/O module */
134 #define BUFFER_SIZE 8192
141 gfc_offset buffer_offset; /* File offset of the start of the buffer */
142 gfc_offset physical_offset; /* Current physical file offset */
143 gfc_offset logical_offset; /* Current logical file offset */
144 gfc_offset dirty_offset; /* Start of modified bytes in buffer */
145 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
147 int len; /* Physical length of the current buffer */
148 int active; /* Length of valid bytes in the buffer */
151 int ndirty; /* Dirty bytes starting at dirty_offset */
153 int special_file; /* =1 if the fd refers to a special file */
155 io_mode method; /* Method of stream I/O being used */
158 char small_buffer[BUFFER_SIZE];
163 /* Stream structure for internal files. Fields must be kept in sync
164 with unix_stream above, except for the buffer. For internal files
165 we point the buffer pointer directly at the destination memory. */
172 gfc_offset buffer_offset; /* File offset of the start of the buffer */
173 gfc_offset physical_offset; /* Current physical file offset */
174 gfc_offset logical_offset; /* Current logical file offset */
175 gfc_offset dirty_offset; /* Start of modified bytes in buffer */
176 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
178 int len; /* Physical length of the current buffer */
179 int active; /* Length of valid bytes in the buffer */
182 int ndirty; /* Dirty bytes starting at dirty_offset */
184 int special_file; /* =1 if the fd refers to a special file */
186 io_mode method; /* Method of stream I/O being used */
192 /* This implementation of stream I/O is based on the paper:
194 * "Exploiting the advantages of mapped files for stream I/O",
195 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
196 * USENIX conference", p. 27-42.
198 * It differs in a number of ways from the version described in the
199 * paper. First of all, threads are not an issue during I/O and we
200 * also don't have to worry about having multiple regions, since
201 * fortran's I/O model only allows you to be one place at a time.
203 * On the other hand, we have to be able to writing at the end of a
204 * stream, read from the start of a stream or read and write blocks of
205 * bytes from an arbitrary position. After opening a file, a pointer
206 * to a stream structure is returned, which is used to handle file
207 * accesses until the file is closed.
209 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
210 * pointer to a block of memory that mirror the file at position
211 * 'where' that is 'len' bytes long. The len integer is updated to
212 * reflect how many bytes were actually read. The only reason for a
213 * short read is end of file. The file pointer is updated. The
214 * pointer is valid until the next call to salloc_*.
216 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
217 * a pointer to a block of memory that is updated to reflect the state
218 * of the file. The length of the buffer is always equal to that
219 * requested. The buffer must be completely set by the caller. When
220 * data has been written, the sfree() function must be called to
221 * indicate that the caller is done writing data to the buffer. This
222 * may or may not cause a physical write.
224 * Short forms of these are salloc_r() and salloc_w() which drop the
225 * 'where' parameter and use the current file pointer. */
228 /*move_pos_offset()-- Move the record pointer right or left
229 *relative to current position */
232 move_pos_offset (stream* st, int pos_off)
234 unix_stream * str = (unix_stream*)st;
237 str->logical_offset += pos_off;
239 if (str->dirty_offset + str->ndirty > str->logical_offset)
241 if (str->ndirty + pos_off > 0)
242 str->ndirty += pos_off;
245 str->dirty_offset += pos_off + pos_off;
256 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
257 * standard descriptors, returning a non-standard descriptor. If the
258 * user specifies that system errors should go to standard output,
259 * then closes standard output, we don't want the system errors to a
260 * file that has been given file descriptor 1 or 0. We want to send
261 * the error to the invalid descriptor. */
267 int input, output, error;
269 input = output = error = 0;
271 /* Unix allocates the lowest descriptors first, so a loop is not
272 required, but this order is. */
273 if (fd == STDIN_FILENO)
278 if (fd == STDOUT_FILENO)
283 if (fd == STDERR_FILENO)
290 close (STDIN_FILENO);
292 close (STDOUT_FILENO);
294 close (STDERR_FILENO);
301 is_preconnected (stream * s)
305 fd = ((unix_stream *) s)->fd;
306 if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO)
312 /* If the stream corresponds to a preconnected unit, we flush the
313 corresponding C stream. This is bugware for mixed C-Fortran codes
314 where the C code doesn't flush I/O before returning. */
316 flush_if_preconnected (stream * s)
320 fd = ((unix_stream *) s)->fd;
321 if (fd == STDIN_FILENO)
323 else if (fd == STDOUT_FILENO)
325 else if (fd == STDERR_FILENO)
330 /* Reset a stream after reading/writing. Assumes that the buffers have
334 reset_stream (unix_stream * s, size_t bytes_rw)
336 s->physical_offset += bytes_rw;
337 s->logical_offset = s->physical_offset;
338 if (s->file_length != -1 && s->physical_offset > s->file_length)
339 s->file_length = s->physical_offset;
343 /* Read bytes into a buffer, allowing for short reads. If the nbytes
344 * argument is less on return than on entry, it is because we've hit
345 * the end of file. */
348 do_read (unix_stream * s, void * buf, size_t * nbytes)
356 bytes_left = *nbytes;
357 buf_st = (char *) buf;
359 /* We must read in a loop since some systems don't restart system
360 calls in case of a signal. */
361 while (bytes_left > 0)
363 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
364 so we must read in chunks smaller than SSIZE_MAX. */
365 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
366 trans = read (s->fd, buf_st, trans);
377 else if (trans == 0) /* We hit EOF. */
383 *nbytes -= bytes_left;
388 /* Write a buffer to a stream, allowing for short writes. */
391 do_write (unix_stream * s, const void * buf, size_t * nbytes)
399 bytes_left = *nbytes;
400 buf_st = (char *) buf;
402 /* We must write in a loop since some systems don't restart system
403 calls in case of a signal. */
404 while (bytes_left > 0)
406 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
407 so we must write in chunks smaller than SSIZE_MAX. */
408 trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
409 trans = write (s->fd, buf_st, trans);
424 *nbytes -= bytes_left;
429 /* get_oserror()-- Get the most recent operating system error. For
430 * unix, this is errno. */
435 return strerror (errno);
439 /*********************************************************************
440 File descriptor stream functions
441 *********************************************************************/
444 /* fd_flush()-- Write bytes that need to be written */
447 fd_flush (unix_stream * s)
454 if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
455 lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
458 writelen = s->ndirty;
459 if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
463 s->physical_offset = s->dirty_offset + writelen;
465 /* don't increment file_length if the file is non-seekable */
466 if (s->file_length != -1 && s->physical_offset > s->file_length)
467 s->file_length = s->physical_offset;
469 s->ndirty -= writelen;
477 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
478 * satisfied. This subroutine gets the buffer ready for whatever is
482 fd_alloc (unix_stream * s, gfc_offset where,
483 int *len __attribute__ ((unused)))
488 if (*len <= BUFFER_SIZE)
490 new_buffer = s->small_buffer;
491 read_len = BUFFER_SIZE;
495 new_buffer = get_mem (*len);
499 /* Salvage bytes currently within the buffer. This is important for
500 * devices that cannot seek. */
502 if (s->buffer != NULL && s->buffer_offset <= where &&
503 where <= s->buffer_offset + s->active)
506 n = s->active - (where - s->buffer_offset);
507 memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
512 { /* new buffer starts off empty */
516 s->buffer_offset = where;
518 /* free the old buffer if necessary */
520 if (s->buffer != NULL && s->buffer != s->small_buffer)
521 free_mem (s->buffer);
523 s->buffer = new_buffer;
528 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
529 * we've already buffered the data or we need to load it. Returns
530 * NULL on I/O error. */
533 fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
538 where = s->logical_offset;
540 if (s->buffer != NULL && s->buffer_offset <= where &&
541 where + *len <= s->buffer_offset + s->active)
544 /* Return a position within the current buffer */
546 s->logical_offset = where + *len;
547 return s->buffer + where - s->buffer_offset;
550 fd_alloc (s, where, len);
552 m = where + s->active;
554 if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
557 /* do_read() hangs on read from terminals for *BSD-systems. Only
558 use read() in that case. */
564 n = read (s->fd, s->buffer + s->active, s->len - s->active);
568 s->physical_offset = m + n;
575 n = s->len - s->active;
576 if (do_read (s, s->buffer + s->active, &n) != 0)
579 s->physical_offset = m + n;
583 if (s->active < *len)
584 *len = s->active; /* Bytes actually available */
586 s->logical_offset = where + *len;
592 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
593 * we've already buffered the data or we need to load it. */
596 fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
601 where = s->logical_offset;
603 if (s->buffer == NULL || s->buffer_offset > where ||
604 where + *len > s->buffer_offset + s->len)
607 if (fd_flush (s) == FAILURE)
609 fd_alloc (s, where, len);
612 /* Return a position within the current buffer */
614 || where > s->dirty_offset + s->ndirty
615 || s->dirty_offset > where + *len)
616 { /* Discontiguous blocks, start with a clean buffer. */
617 /* Flush the buffer. */
620 s->dirty_offset = where;
625 gfc_offset start; /* Merge with the existing data. */
626 if (where < s->dirty_offset)
629 start = s->dirty_offset;
630 if (where + *len > s->dirty_offset + s->ndirty)
631 s->ndirty = where + *len - start;
633 s->ndirty = s->dirty_offset + s->ndirty - start;
634 s->dirty_offset = start;
637 s->logical_offset = where + *len;
639 /* Don't increment file_length if the file is non-seekable. */
641 if (s->file_length != -1 && s->logical_offset > s->file_length)
642 s->file_length = s->logical_offset;
644 n = s->logical_offset - s->buffer_offset;
648 return s->buffer + where - s->buffer_offset;
653 fd_sfree (unix_stream * s)
655 if (s->ndirty != 0 &&
656 (s->buffer != s->small_buffer || options.all_unbuffered ||
657 s->method == SYNC_UNBUFFERED))
665 fd_seek (unix_stream * s, gfc_offset offset)
668 if (s->file_length == -1)
671 if (s->physical_offset == offset) /* Are we lucky and avoid syscall? */
673 s->logical_offset = offset;
677 if (lseek (s->fd, offset, SEEK_SET) >= 0)
679 s->physical_offset = s->logical_offset = offset;
688 /* truncate_file()-- Given a unit, truncate the file at the current
689 * position. Sets the physical location to the new end of the file.
690 * Returns nonzero on error. */
693 fd_truncate (unix_stream * s)
695 /* Non-seekable files, like terminals and fifo's fail the lseek so just
696 return success, there is nothing to truncate. If its not a pipe there
697 is a real problem. */
698 if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
706 /* Using ftruncate on a seekable special file (like /dev/null)
707 is undefined, so we treat it as if the ftruncate succeeded. */
710 #ifdef HAVE_FTRUNCATE
711 ftruncate (s->fd, s->logical_offset) != 0
712 #elif defined HAVE_CHSIZE
713 chsize (s->fd, s->logical_offset) != 0
715 /* If we have neither, always fail and exit, noisily. */
716 runtime_error ("required ftruncate or chsize support not present"), 1
720 /* The truncation failed and we need to handle this gracefully.
721 The file length remains the same, but the file-descriptor
722 offset needs adjustment per the successful lseek above.
723 (Similarly, the contents of the buffer isn't valid anymore.)
724 A ftruncate call does not affect the physical (file-descriptor)
725 offset, according to the ftruncate manual, so neither should a
727 s->physical_offset = s->logical_offset;
732 s->physical_offset = s->file_length = s->logical_offset;
738 /* Similar to memset(), but operating on a stream instead of a string.
739 Takes care of not using too much memory. */
742 fd_sset (unix_stream * s, int c, size_t n)
750 while (bytes_left > 0)
752 /* memset() in chunks of BUFFER_SIZE. */
753 trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
755 p = fd_alloc_w_at (s, &trans, -1);
757 memset (p, c, trans);
768 /* Stream read function. Avoids using a buffer for big reads. The
769 interface is like POSIX read(), but the nbytes argument is a
770 pointer; on return it contains the number of bytes written. The
771 function return value is the status indicator (0 for success). */
774 fd_read (unix_stream * s, void * buf, size_t * nbytes)
779 if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
782 p = fd_alloc_r_at (s, &tmp, -1);
786 memcpy (buf, p, *nbytes);
796 /* If the request is bigger than BUFFER_SIZE we flush the buffers
797 and read directly. */
798 if (fd_flush (s) == FAILURE)
804 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
810 status = do_read (s, buf, nbytes);
811 reset_stream (s, *nbytes);
816 /* Stream write function. Avoids using a buffer for big writes. The
817 interface is like POSIX write(), but the nbytes argument is a
818 pointer; on return it contains the number of bytes written. The
819 function return value is the status indicator (0 for success). */
822 fd_write (unix_stream * s, const void * buf, size_t * nbytes)
827 if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
830 p = fd_alloc_w_at (s, &tmp, -1);
834 memcpy (p, buf, *nbytes);
844 /* If the request is bigger than BUFFER_SIZE we flush the buffers
845 and write directly. */
846 if (fd_flush (s) == FAILURE)
852 if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
858 status = do_write (s, buf, nbytes);
859 reset_stream (s, *nbytes);
865 fd_close (unix_stream * s)
867 if (fd_flush (s) == FAILURE)
870 if (s->buffer != NULL && s->buffer != s->small_buffer)
871 free_mem (s->buffer);
873 if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO && s->fd != STDIN_FILENO)
875 if (close (s->fd) < 0)
886 fd_open (unix_stream * s)
889 s->method = SYNC_UNBUFFERED;
891 s->method = SYNC_BUFFERED;
893 s->st.alloc_r_at = (void *) fd_alloc_r_at;
894 s->st.alloc_w_at = (void *) fd_alloc_w_at;
895 s->st.sfree = (void *) fd_sfree;
896 s->st.close = (void *) fd_close;
897 s->st.seek = (void *) fd_seek;
898 s->st.trunc = (void *) fd_truncate;
899 s->st.read = (void *) fd_read;
900 s->st.write = (void *) fd_write;
901 s->st.set = (void *) fd_sset;
909 /*********************************************************************
910 memory stream functions - These are used for internal files
912 The idea here is that a single stream structure is created and all
913 requests must be satisfied from it. The location and size of the
914 buffer is the character variable supplied to the READ or WRITE
917 *********************************************************************/
921 mem_alloc_r_at (int_stream * s, int *len, gfc_offset where)
926 where = s->logical_offset;
928 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
931 s->logical_offset = where + *len;
933 n = s->buffer_offset + s->active - where;
937 return s->buffer + (where - s->buffer_offset);
942 mem_alloc_w_at (int_stream * s, int *len, gfc_offset where)
946 assert (*len >= 0); /* Negative values not allowed. */
949 where = s->logical_offset;
953 if (where < s->buffer_offset)
956 if (m > s->file_length)
959 s->logical_offset = m;
961 return s->buffer + (where - s->buffer_offset);
965 /* Stream read function for internal units. This is not actually used
966 at the moment, as all internal IO is formatted and the formatted IO
967 routines use mem_alloc_r_at. */
970 mem_read (int_stream * s, void * buf, size_t * nbytes)
976 p = mem_alloc_r_at (s, &tmp, -1);
980 memcpy (buf, p, *nbytes);
991 /* Stream write function for internal units. This is not actually used
992 at the moment, as all internal IO is formatted and the formatted IO
993 routines use mem_alloc_w_at. */
996 mem_write (int_stream * s, const void * buf, size_t * nbytes)
1004 p = mem_alloc_w_at (s, &tmp, -1);
1008 memcpy (p, buf, *nbytes);
1020 mem_seek (int_stream * s, gfc_offset offset)
1022 if (offset > s->file_length)
1028 s->logical_offset = offset;
1034 mem_set (int_stream * s, int c, size_t n)
1041 p = mem_alloc_w_at (s, &len, -1);
1053 mem_truncate (int_stream * s __attribute__ ((unused)))
1060 mem_close (int_stream * s)
1070 mem_sfree (int_stream * s __attribute__ ((unused)))
1077 /*********************************************************************
1078 Public functions -- A reimplementation of this module needs to
1079 define functional equivalents of the following.
1080 *********************************************************************/
1082 /* empty_internal_buffer()-- Zero the buffer of Internal file */
1085 empty_internal_buffer(stream *strm)
1087 int_stream * s = (int_stream *) strm;
1088 memset(s->buffer, ' ', s->file_length);
1091 /* open_internal()-- Returns a stream structure from an internal file */
1094 open_internal (char *base, int length, gfc_offset offset)
1098 s = get_mem (sizeof (int_stream));
1099 memset (s, '\0', sizeof (int_stream));
1102 s->buffer_offset = offset;
1104 s->logical_offset = 0;
1105 s->active = s->file_length = length;
1107 s->st.alloc_r_at = (void *) mem_alloc_r_at;
1108 s->st.alloc_w_at = (void *) mem_alloc_w_at;
1109 s->st.sfree = (void *) mem_sfree;
1110 s->st.close = (void *) mem_close;
1111 s->st.seek = (void *) mem_seek;
1112 s->st.trunc = (void *) mem_truncate;
1113 s->st.read = (void *) mem_read;
1114 s->st.write = (void *) mem_write;
1115 s->st.set = (void *) mem_set;
1117 return (stream *) s;
1121 /* fd_to_stream()-- Given an open file descriptor, build a stream
1125 fd_to_stream (int fd, int prot)
1127 struct stat statbuf;
1130 s = get_mem (sizeof (unix_stream));
1131 memset (s, '\0', sizeof (unix_stream));
1134 s->buffer_offset = 0;
1135 s->physical_offset = 0;
1136 s->logical_offset = 0;
1139 /* Get the current length of the file. */
1141 fstat (fd, &statbuf);
1143 if (lseek (fd, 0, SEEK_CUR) == (off_t) -1)
1144 s->file_length = -1;
1146 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
1148 s->special_file = !S_ISREG (statbuf.st_mode);
1152 return (stream *) s;
1156 /* Given the Fortran unit number, convert it to a C file descriptor. */
1159 unit_to_fd (int unit)
1164 us = find_unit (unit);
1168 fd = ((unix_stream *) us->s)->fd;
1174 /* unpack_filename()-- Given a fortran string and a pointer to a
1175 * buffer that is PATH_MAX characters, convert the fortran string to a
1176 * C string in the buffer. Returns nonzero if this is not possible. */
1179 unpack_filename (char *cstring, const char *fstring, int len)
1181 len = fstrlen (fstring, len);
1182 if (len >= PATH_MAX)
1185 memmove (cstring, fstring, len);
1186 cstring[len] = '\0';
1192 /* tempfile()-- Generate a temporary filename for a scratch file and
1193 * open it. mkstemp() opens the file for reading and writing, but the
1194 * library mode prevents anything that is not allowed. The descriptor
1195 * is returned, which is -1 on error. The template is pointed to by
1196 * opp->file, which is copied into the unit structure
1197 * and freed later. */
1200 tempfile (st_parameter_open *opp)
1202 const char *tempdir;
1206 tempdir = getenv ("GFORTRAN_TMPDIR");
1207 if (tempdir == NULL)
1208 tempdir = getenv ("TMP");
1209 if (tempdir == NULL)
1210 tempdir = getenv ("TEMP");
1211 if (tempdir == NULL)
1212 tempdir = DEFAULT_TEMPDIR;
1214 template = get_mem (strlen (tempdir) + 20);
1216 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
1220 fd = mkstemp (template);
1222 #else /* HAVE_MKSTEMP */
1224 if (mktemp (template))
1226 #if defined(HAVE_CRLF) && defined(O_BINARY)
1227 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1228 S_IREAD | S_IWRITE);
1230 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1232 while (!(fd == -1 && errno == EEXIST) && mktemp (template));
1236 #endif /* HAVE_MKSTEMP */
1239 free_mem (template);
1242 opp->file = template;
1243 opp->file_len = strlen (template); /* Don't include trailing nul */
1250 /* regular_file()-- Open a regular file.
1251 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1252 * unless an error occurs.
1253 * Returns the descriptor, which is less than zero on error. */
1256 regular_file (st_parameter_open *opp, unit_flags *flags)
1258 char path[PATH_MAX + 1];
1264 if (unpack_filename (path, opp->file, opp->file_len))
1266 errno = ENOENT; /* Fake an OS error */
1272 switch (flags->action)
1282 case ACTION_READWRITE:
1283 case ACTION_UNSPECIFIED:
1288 internal_error (&opp->common, "regular_file(): Bad action");
1291 switch (flags->status)
1294 crflag = O_CREAT | O_EXCL;
1297 case STATUS_OLD: /* open will fail if the file does not exist*/
1301 case STATUS_UNKNOWN:
1302 case STATUS_SCRATCH:
1306 case STATUS_REPLACE:
1307 crflag = O_CREAT | O_TRUNC;
1311 internal_error (&opp->common, "regular_file(): Bad status");
1314 /* rwflag |= O_LARGEFILE; */
1316 #if defined(HAVE_CRLF) && defined(O_BINARY)
1320 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1321 fd = open (path, rwflag | crflag, mode);
1322 if (flags->action != ACTION_UNSPECIFIED)
1327 flags->action = ACTION_READWRITE;
1330 if (errno != EACCES && errno != EROFS)
1333 /* retry for read-only access */
1335 fd = open (path, rwflag | crflag, mode);
1338 flags->action = ACTION_READ;
1339 return fd; /* success */
1342 if (errno != EACCES)
1343 return fd; /* failure */
1345 /* retry for write-only access */
1347 fd = open (path, rwflag | crflag, mode);
1350 flags->action = ACTION_WRITE;
1351 return fd; /* success */
1353 return fd; /* failure */
1357 /* open_external()-- Open an external file, unix specific version.
1358 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1359 * Returns NULL on operating system error. */
1362 open_external (st_parameter_open *opp, unit_flags *flags)
1366 if (flags->status == STATUS_SCRATCH)
1368 fd = tempfile (opp);
1369 if (flags->action == ACTION_UNSPECIFIED)
1370 flags->action = ACTION_READWRITE;
1372 #if HAVE_UNLINK_OPEN_FILE
1373 /* We can unlink scratch files now and it will go away when closed. */
1380 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1382 fd = regular_file (opp, flags);
1389 switch (flags->action)
1399 case ACTION_READWRITE:
1400 prot = PROT_READ | PROT_WRITE;
1404 internal_error (&opp->common, "open_external(): Bad action");
1407 return fd_to_stream (fd, prot);
1411 /* input_stream()-- Return a stream pointer to the default input stream.
1412 * Called on initialization. */
1417 return fd_to_stream (STDIN_FILENO, PROT_READ);
1421 /* output_stream()-- Return a stream pointer to the default output stream.
1422 * Called on initialization. */
1425 output_stream (void)
1429 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1430 setmode (STDOUT_FILENO, O_BINARY);
1433 s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1434 if (options.unbuffered_preconnected)
1435 ((unix_stream *) s)->method = SYNC_UNBUFFERED;
1440 /* error_stream()-- Return a stream pointer to the default error stream.
1441 * Called on initialization. */
1448 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1449 setmode (STDERR_FILENO, O_BINARY);
1452 s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1453 if (options.unbuffered_preconnected)
1454 ((unix_stream *) s)->method = SYNC_UNBUFFERED;
1459 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1460 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1461 is big enough to completely fill a 80x25 terminal, so it shuld be
1462 OK. We use a direct write() because it is simpler and least likely
1463 to be clobbered by memory corruption. Writing an error message
1464 longer than that is an error. */
1466 #define ST_VPRINTF_SIZE 2048
1469 st_vprintf (const char *format, va_list ap)
1471 static char buffer[ST_VPRINTF_SIZE];
1475 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1476 #ifdef HAVE_VSNPRINTF
1477 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1479 written = vsprintf(buffer, format, ap);
1481 if (written >= ST_VPRINTF_SIZE-1)
1483 /* The error message was longer than our buffer. Ouch. Because
1484 we may have messed up things badly, report the error and
1486 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1487 write (fd, buffer, ST_VPRINTF_SIZE-1);
1488 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1490 #undef ERROR_MESSAGE
1495 written = write (fd, buffer, written);
1499 /* st_printf()-- printf() function for error output. This just calls
1500 st_vprintf() to do the actual work. */
1503 st_printf (const char *format, ...)
1507 va_start (ap, format);
1508 written = st_vprintf(format, ap);
1514 /* compare_file_filename()-- Given an open stream and a fortran string
1515 * that is a filename, figure out if the file is the same as the
1519 compare_file_filename (gfc_unit *u, const char *name, int len)
1521 char path[PATH_MAX + 1];
1523 #ifdef HAVE_WORKING_STAT
1531 if (unpack_filename (path, name, len))
1532 return 0; /* Can't be the same */
1534 /* If the filename doesn't exist, then there is no match with the
1537 if (stat (path, &st1) < 0)
1540 #ifdef HAVE_WORKING_STAT
1541 fstat (((unix_stream *) (u->s))->fd, &st2);
1542 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1546 /* We try to match files by a unique ID. On some filesystems (network
1547 fs and FAT), we can't generate this unique ID, and will simply compare
1549 id1 = id_from_path (path);
1550 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1552 return (id1 == id2);
1555 if (len != u->file_len)
1557 return (memcmp(path, u->file, len) == 0);
1562 #ifdef HAVE_WORKING_STAT
1563 # define FIND_FILE0_DECL struct stat *st
1564 # define FIND_FILE0_ARGS st
1566 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1567 # define FIND_FILE0_ARGS id, file, file_len
1570 /* find_file0()-- Recursive work function for find_file() */
1573 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1576 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1583 #ifdef HAVE_WORKING_STAT
1585 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1586 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1590 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1597 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1601 v = find_file0 (u->left, FIND_FILE0_ARGS);
1605 v = find_file0 (u->right, FIND_FILE0_ARGS);
1613 /* find_file()-- Take the current filename and see if there is a unit
1614 * that has the file already open. Returns a pointer to the unit if so. */
1617 find_file (const char *file, gfc_charlen_type file_len)
1619 char path[PATH_MAX + 1];
1624 if (unpack_filename (path, file, file_len))
1627 if (stat (path, &st[0]) < 0)
1630 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1631 id = id_from_path (path);
1636 __gthread_mutex_lock (&unit_lock);
1638 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1642 if (! __gthread_mutex_trylock (&u->lock))
1644 /* assert (u->closed == 0); */
1645 __gthread_mutex_unlock (&unit_lock);
1649 inc_waiting_locked (u);
1651 __gthread_mutex_unlock (&unit_lock);
1654 __gthread_mutex_lock (&u->lock);
1657 __gthread_mutex_lock (&unit_lock);
1658 __gthread_mutex_unlock (&u->lock);
1659 if (predec_waiting_locked (u) == 0)
1664 dec_waiting_unlocked (u);
1670 flush_all_units_1 (gfc_unit *u, int min_unit)
1674 if (u->unit_number > min_unit)
1676 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1680 if (u->unit_number >= min_unit)
1682 if (__gthread_mutex_trylock (&u->lock))
1686 __gthread_mutex_unlock (&u->lock);
1694 flush_all_units (void)
1699 __gthread_mutex_lock (&unit_lock);
1702 u = flush_all_units_1 (unit_root, min_unit);
1704 inc_waiting_locked (u);
1705 __gthread_mutex_unlock (&unit_lock);
1709 __gthread_mutex_lock (&u->lock);
1711 min_unit = u->unit_number + 1;
1716 __gthread_mutex_lock (&unit_lock);
1717 __gthread_mutex_unlock (&u->lock);
1718 (void) predec_waiting_locked (u);
1722 __gthread_mutex_lock (&unit_lock);
1723 __gthread_mutex_unlock (&u->lock);
1724 if (predec_waiting_locked (u) == 0)
1732 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1736 stream_at_bof (stream * s)
1740 if (!is_seekable (s))
1743 us = (unix_stream *) s;
1745 return us->logical_offset == 0;
1749 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1753 stream_at_eof (stream * s)
1757 if (!is_seekable (s))
1760 us = (unix_stream *) s;
1762 return us->logical_offset == us->dirty_offset;
1766 /* delete_file()-- Given a unit structure, delete the file associated
1767 * with the unit. Returns nonzero if something went wrong. */
1770 delete_file (gfc_unit * u)
1772 char path[PATH_MAX + 1];
1774 if (unpack_filename (path, u->file, u->file_len))
1775 { /* Shouldn't be possible */
1780 return unlink (path);
1784 /* file_exists()-- Returns nonzero if the current filename exists on
1788 file_exists (const char *file, gfc_charlen_type file_len)
1790 char path[PATH_MAX + 1];
1791 struct stat statbuf;
1793 if (unpack_filename (path, file, file_len))
1796 if (stat (path, &statbuf) < 0)
1804 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1806 /* inquire_sequential()-- Given a fortran string, determine if the
1807 * file is suitable for sequential access. Returns a C-style
1811 inquire_sequential (const char *string, int len)
1813 char path[PATH_MAX + 1];
1814 struct stat statbuf;
1816 if (string == NULL ||
1817 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1820 if (S_ISREG (statbuf.st_mode) ||
1821 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1824 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1831 /* inquire_direct()-- Given a fortran string, determine if the file is
1832 * suitable for direct access. Returns a C-style string. */
1835 inquire_direct (const char *string, int len)
1837 char path[PATH_MAX + 1];
1838 struct stat statbuf;
1840 if (string == NULL ||
1841 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1844 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1847 if (S_ISDIR (statbuf.st_mode) ||
1848 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1855 /* inquire_formatted()-- Given a fortran string, determine if the file
1856 * is suitable for formatted form. Returns a C-style string. */
1859 inquire_formatted (const char *string, int len)
1861 char path[PATH_MAX + 1];
1862 struct stat statbuf;
1864 if (string == NULL ||
1865 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1868 if (S_ISREG (statbuf.st_mode) ||
1869 S_ISBLK (statbuf.st_mode) ||
1870 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1873 if (S_ISDIR (statbuf.st_mode))
1880 /* inquire_unformatted()-- Given a fortran string, determine if the file
1881 * is suitable for unformatted form. Returns a C-style string. */
1884 inquire_unformatted (const char *string, int len)
1886 return inquire_formatted (string, len);
1900 /* Fallback implementation of access() on systems that don't have it.
1901 Only modes R_OK and W_OK are used in this file. */
1904 fallback_access (const char *path, int mode)
1906 if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1909 if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1916 #define access fallback_access
1920 /* inquire_access()-- Given a fortran string, determine if the file is
1921 * suitable for access. */
1924 inquire_access (const char *string, int len, int mode)
1926 char path[PATH_MAX + 1];
1928 if (string == NULL || unpack_filename (path, string, len) ||
1929 access (path, mode) < 0)
1936 /* inquire_read()-- Given a fortran string, determine if the file is
1937 * suitable for READ access. */
1940 inquire_read (const char *string, int len)
1942 return inquire_access (string, len, R_OK);
1946 /* inquire_write()-- Given a fortran string, determine if the file is
1947 * suitable for READ access. */
1950 inquire_write (const char *string, int len)
1952 return inquire_access (string, len, W_OK);
1956 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1957 * suitable for read and write access. */
1960 inquire_readwrite (const char *string, int len)
1962 return inquire_access (string, len, R_OK | W_OK);
1966 /* file_length()-- Return the file length in bytes, -1 if unknown */
1969 file_length (stream * s)
1971 return ((unix_stream *) s)->file_length;
1975 /* file_position()-- Return the current position of the file */
1978 file_position (stream *s)
1980 return ((unix_stream *) s)->logical_offset;
1984 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1988 is_seekable (stream *s)
1990 /* By convention, if file_length == -1, the file is not
1992 return ((unix_stream *) s)->file_length!=-1;
1996 /* is_special()-- Return nonzero if the stream is not a regular file. */
1999 is_special (stream *s)
2001 return ((unix_stream *) s)->special_file;
2008 return fd_flush( (unix_stream *) s);
2012 stream_isatty (stream *s)
2014 return isatty (((unix_stream *) s)->fd);
2018 stream_ttyname (stream *s __attribute__ ((unused)))
2021 return ttyname (((unix_stream *) s)->fd);
2028 stream_offset (stream *s)
2030 return (((unix_stream *) s)->logical_offset);
2034 /* How files are stored: This is an operating-system specific issue,
2035 and therefore belongs here. There are three cases to consider.
2038 Records are written as block of bytes corresponding to the record
2039 length of the file. This goes for both formatted and unformatted
2040 records. Positioning is done explicitly for each data transfer,
2041 so positioning is not much of an issue.
2043 Sequential Formatted:
2044 Records are separated by newline characters. The newline character
2045 is prohibited from appearing in a string. If it does, this will be
2046 messed up on the next read. End of file is also the end of a record.
2048 Sequential Unformatted:
2049 In this case, we are merely copying bytes to and from main storage,
2050 yet we need to keep track of varying record lengths. We adopt
2051 the solution used by f2c. Each record contains a pair of length
2054 Length of record n in bytes
2056 Length of record n in bytes
2058 Length of record n+1 in bytes
2060 Length of record n+1 in bytes
2062 The length is stored at the end of a record to allow backspacing to the
2063 previous record. Between data transfer statements, the file pointer
2064 is left pointing to the first length of the current record.
2066 ENDFILE records are never explicitly stored.