1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
28 /* Unix stream I/O module */
44 /* min macro that evaluates its arguments only once. */
46 ({ typeof (a) _a = (a); \
47 typeof (b) _b = (b); \
51 /* For mingw, we don't identify files by their inode number, but by a
52 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
55 #define WIN32_LEAN_AND_MEAN
58 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
60 #define lseek _lseeki64
62 #define fstat _fstati64
67 #ifndef HAVE_WORKING_STAT
69 id_from_handle (HANDLE hFile)
71 BY_HANDLE_FILE_INFORMATION FileInformation;
73 if (hFile == INVALID_HANDLE_VALUE)
76 memset (&FileInformation, 0, sizeof(FileInformation));
77 if (!GetFileInformationByHandle (hFile, &FileInformation))
80 return ((uint64_t) FileInformation.nFileIndexLow)
81 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
86 id_from_path (const char *path)
91 if (!path || !*path || access (path, F_OK))
94 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
95 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
97 res = id_from_handle (hFile);
104 id_from_fd (const int fd)
106 return id_from_handle ((HANDLE) _get_osfhandle (fd));
113 #define PATH_MAX 1024
116 /* These flags aren't defined on all targets (mingw32), so provide them
149 /* Fallback implementation of access() on systems that don't have it.
150 Only modes R_OK, W_OK and F_OK are used in this file. */
153 fallback_access (const char *path, int mode)
157 if ((mode & R_OK) && (fd = open (path, O_RDONLY)) < 0)
161 if ((mode & W_OK) && (fd = open (path, O_WRONLY)) < 0)
168 return stat (path, &st);
175 #define access fallback_access
179 /* Unix and internal stream I/O module */
181 static const int BUFFER_SIZE = 8192;
187 gfc_offset buffer_offset; /* File offset of the start of the buffer */
188 gfc_offset physical_offset; /* Current physical file offset */
189 gfc_offset logical_offset; /* Current logical file offset */
190 gfc_offset file_length; /* Length of the file. */
192 char *buffer; /* Pointer to the buffer. */
193 int fd; /* The POSIX file descriptor. */
195 int active; /* Length of valid bytes in the buffer */
197 int ndirty; /* Dirty bytes starting at buffer_offset */
199 /* Cached stat(2) values. */
206 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
207 * standard descriptors, returning a non-standard descriptor. If the
208 * user specifies that system errors should go to standard output,
209 * then closes standard output, we don't want the system errors to a
210 * file that has been given file descriptor 1 or 0. We want to send
211 * the error to the invalid descriptor. */
217 int input, output, error;
219 input = output = error = 0;
221 /* Unix allocates the lowest descriptors first, so a loop is not
222 required, but this order is. */
223 if (fd == STDIN_FILENO)
228 if (fd == STDOUT_FILENO)
233 if (fd == STDERR_FILENO)
240 close (STDIN_FILENO);
242 close (STDOUT_FILENO);
244 close (STDERR_FILENO);
251 /* If the stream corresponds to a preconnected unit, we flush the
252 corresponding C stream. This is bugware for mixed C-Fortran codes
253 where the C code doesn't flush I/O before returning. */
255 flush_if_preconnected (stream * s)
259 fd = ((unix_stream *) s)->fd;
260 if (fd == STDIN_FILENO)
262 else if (fd == STDOUT_FILENO)
264 else if (fd == STDERR_FILENO)
269 /********************************************************************
270 Raw I/O functions (read, write, seek, tell, truncate, close).
272 These functions wrap the basic POSIX I/O syscalls. Any deviation in
273 semantics is a bug, except the following: write restarts in case
274 of being interrupted by a signal, and as the first argument the
275 functions take the unix_stream struct rather than an integer file
276 descriptor. Also, for POSIX read() and write() a nbyte argument larger
277 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
278 than size_t as for POSIX read/write.
279 *********************************************************************/
282 raw_flush (unix_stream * s __attribute__ ((unused)))
288 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
290 /* For read we can't do I/O in a loop like raw_write does, because
291 that will break applications that wait for interactive I/O. */
292 return read (s->fd, buf, nbyte);
296 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
298 ssize_t trans, bytes_left;
302 buf_st = (char *) buf;
304 /* We must write in a loop since some systems don't restart system
305 calls in case of a signal. */
306 while (bytes_left > 0)
308 trans = write (s->fd, buf_st, bytes_left);
320 return nbyte - bytes_left;
324 raw_seek (unix_stream * s, gfc_offset offset, int whence)
326 return lseek (s->fd, offset, whence);
330 raw_tell (unix_stream * s)
332 return lseek (s->fd, 0, SEEK_CUR);
336 raw_size (unix_stream * s)
339 int ret = fstat (s->fd, &statbuf);
342 return statbuf.st_size;
346 raw_truncate (unix_stream * s, gfc_offset length)
357 h = (HANDLE) _get_osfhandle (s->fd);
358 if (h == INVALID_HANDLE_VALUE)
363 cur = lseek (s->fd, 0, SEEK_CUR);
366 if (lseek (s->fd, length, SEEK_SET) == -1)
368 if (!SetEndOfFile (h))
373 if (lseek (s->fd, cur, SEEK_SET) == -1)
377 lseek (s->fd, cur, SEEK_SET);
379 #elif defined HAVE_FTRUNCATE
380 return ftruncate (s->fd, length);
381 #elif defined HAVE_CHSIZE
382 return chsize (s->fd, length);
384 runtime_error ("required ftruncate or chsize support not present");
390 raw_close (unix_stream * s)
394 if (s->fd != STDOUT_FILENO
395 && s->fd != STDERR_FILENO
396 && s->fd != STDIN_FILENO)
397 retval = close (s->fd);
405 raw_init (unix_stream * s)
407 s->st.read = (void *) raw_read;
408 s->st.write = (void *) raw_write;
409 s->st.seek = (void *) raw_seek;
410 s->st.tell = (void *) raw_tell;
411 s->st.size = (void *) raw_size;
412 s->st.trunc = (void *) raw_truncate;
413 s->st.close = (void *) raw_close;
414 s->st.flush = (void *) raw_flush;
421 /*********************************************************************
422 Buffered I/O functions. These functions have the same semantics as the
423 raw I/O functions above, except that they are buffered in order to
424 improve performance. The buffer must be flushed when switching from
425 reading to writing and vice versa. Only supported for regular files.
426 *********************************************************************/
429 buf_flush (unix_stream * s)
433 /* Flushing in read mode means discarding read bytes. */
439 if (s->physical_offset != s->buffer_offset
440 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
443 writelen = raw_write (s, s->buffer, s->ndirty);
445 s->physical_offset = s->buffer_offset + writelen;
447 if (s->physical_offset > s->file_length)
448 s->file_length = s->physical_offset;
450 s->ndirty -= writelen;
462 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
465 s->buffer_offset = s->logical_offset;
467 /* Is the data we want in the buffer? */
468 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
469 && s->buffer_offset <= s->logical_offset)
470 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
473 /* First copy the active bytes if applicable, then read the rest
474 either directly or filling the buffer. */
477 ssize_t to_read, did_read;
478 gfc_offset new_logical;
481 if (s->logical_offset >= s->buffer_offset
482 && s->buffer_offset + s->active >= s->logical_offset)
484 nread = s->active - (s->logical_offset - s->buffer_offset);
485 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
489 /* At this point we consider all bytes in the buffer discarded. */
490 to_read = nbyte - nread;
491 new_logical = s->logical_offset + nread;
492 if (s->physical_offset != new_logical
493 && lseek (s->fd, new_logical, SEEK_SET) < 0)
495 s->buffer_offset = s->physical_offset = new_logical;
496 if (to_read <= BUFFER_SIZE/2)
498 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
499 s->physical_offset += did_read;
500 s->active = did_read;
501 did_read = (did_read > to_read) ? to_read : did_read;
502 memcpy (p, s->buffer, did_read);
506 did_read = raw_read (s, p, to_read);
507 s->physical_offset += did_read;
510 nbyte = did_read + nread;
512 s->logical_offset += nbyte;
517 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
520 s->buffer_offset = s->logical_offset;
522 /* Does the data fit into the buffer? As a special case, if the
523 buffer is empty and the request is bigger than BUFFER_SIZE/2,
524 write directly. This avoids the case where the buffer would have
525 to be flushed at every write. */
526 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
527 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
528 && s->buffer_offset <= s->logical_offset
529 && s->buffer_offset + s->ndirty >= s->logical_offset)
531 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
532 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
538 /* Flush, and either fill the buffer with the new data, or if
539 the request is bigger than the buffer size, write directly
540 bypassing the buffer. */
542 if (nbyte <= BUFFER_SIZE/2)
544 memcpy (s->buffer, buf, nbyte);
545 s->buffer_offset = s->logical_offset;
550 if (s->physical_offset != s->logical_offset)
552 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
554 s->physical_offset = s->logical_offset;
557 nbyte = raw_write (s, buf, nbyte);
558 s->physical_offset += nbyte;
561 s->logical_offset += nbyte;
562 if (s->logical_offset > s->file_length)
563 s->file_length = s->logical_offset;
568 buf_seek (unix_stream * s, gfc_offset offset, int whence)
575 offset += s->logical_offset;
578 offset += s->file_length;
588 s->logical_offset = offset;
593 buf_tell (unix_stream * s)
595 return buf_seek (s, 0, SEEK_CUR);
599 buf_size (unix_stream * s)
601 return s->file_length;
605 buf_truncate (unix_stream * s, gfc_offset length)
609 if (buf_flush (s) != 0)
611 r = raw_truncate (s, length);
613 s->file_length = length;
618 buf_close (unix_stream * s)
620 if (buf_flush (s) != 0)
623 return raw_close (s);
627 buf_init (unix_stream * s)
629 s->st.read = (void *) buf_read;
630 s->st.write = (void *) buf_write;
631 s->st.seek = (void *) buf_seek;
632 s->st.tell = (void *) buf_tell;
633 s->st.size = (void *) buf_size;
634 s->st.trunc = (void *) buf_truncate;
635 s->st.close = (void *) buf_close;
636 s->st.flush = (void *) buf_flush;
638 s->buffer = get_mem (BUFFER_SIZE);
643 /*********************************************************************
644 memory stream functions - These are used for internal files
646 The idea here is that a single stream structure is created and all
647 requests must be satisfied from it. The location and size of the
648 buffer is the character variable supplied to the READ or WRITE
651 *********************************************************************/
654 mem_alloc_r (stream * strm, int * len)
656 unix_stream * s = (unix_stream *) strm;
658 gfc_offset where = s->logical_offset;
660 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
663 n = s->buffer_offset + s->active - where;
667 s->logical_offset = where + *len;
669 return s->buffer + (where - s->buffer_offset);
674 mem_alloc_r4 (stream * strm, int * len)
676 unix_stream * s = (unix_stream *) strm;
678 gfc_offset where = s->logical_offset;
680 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
683 n = s->buffer_offset + s->active - where;
687 s->logical_offset = where + *len;
689 return s->buffer + (where - s->buffer_offset) * 4;
694 mem_alloc_w (stream * strm, int * len)
696 unix_stream * s = (unix_stream *) strm;
698 gfc_offset where = s->logical_offset;
702 if (where < s->buffer_offset)
705 if (m > s->file_length)
708 s->logical_offset = m;
710 return s->buffer + (where - s->buffer_offset);
715 mem_alloc_w4 (stream * strm, int * len)
717 unix_stream * s = (unix_stream *) strm;
719 gfc_offset where = s->logical_offset;
720 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
724 if (where < s->buffer_offset)
727 if (m > s->file_length)
730 s->logical_offset = m;
731 return &result[where - s->buffer_offset];
735 /* Stream read function for character(kine=1) internal units. */
738 mem_read (stream * s, void * buf, ssize_t nbytes)
743 p = mem_alloc_r (s, &nb);
754 /* Stream read function for chracter(kind=4) internal units. */
757 mem_read4 (stream * s, void * buf, ssize_t nbytes)
762 p = mem_alloc_r (s, &nb);
773 /* Stream write function for character(kind=1) internal units. */
776 mem_write (stream * s, const void * buf, ssize_t nbytes)
781 p = mem_alloc_w (s, &nb);
792 /* Stream write function for character(kind=4) internal units. */
795 mem_write4 (stream * s, const void * buf, ssize_t nwords)
800 p = mem_alloc_w4 (s, &nw);
804 *p++ = (gfc_char4_t) *((char *) buf);
813 mem_seek (stream * strm, gfc_offset offset, int whence)
815 unix_stream * s = (unix_stream *) strm;
821 offset += s->logical_offset;
824 offset += s->file_length;
830 /* Note that for internal array I/O it's actually possible to have a
831 negative offset, so don't check for that. */
832 if (offset > s->file_length)
838 s->logical_offset = offset;
840 /* Returning < 0 is the error indicator for sseek(), so return 0 if
841 offset is negative. Thus if the return value is 0, the caller
842 has to use stell() to get the real value of logical_offset. */
850 mem_tell (stream * s)
852 return ((unix_stream *)s)->logical_offset;
857 mem_truncate (unix_stream * s __attribute__ ((unused)),
858 gfc_offset length __attribute__ ((unused)))
865 mem_flush (unix_stream * s __attribute__ ((unused)))
872 mem_close (unix_stream * s)
880 /*********************************************************************
881 Public functions -- A reimplementation of this module needs to
882 define functional equivalents of the following.
883 *********************************************************************/
885 /* open_internal()-- Returns a stream structure from a character(kind=1)
889 open_internal (char *base, int length, gfc_offset offset)
893 s = get_mem (sizeof (unix_stream));
894 memset (s, '\0', sizeof (unix_stream));
897 s->buffer_offset = offset;
899 s->logical_offset = 0;
900 s->active = s->file_length = length;
902 s->st.close = (void *) mem_close;
903 s->st.seek = (void *) mem_seek;
904 s->st.tell = (void *) mem_tell;
905 /* buf_size is not a typo, we just reuse an identical
907 s->st.size = (void *) buf_size;
908 s->st.trunc = (void *) mem_truncate;
909 s->st.read = (void *) mem_read;
910 s->st.write = (void *) mem_write;
911 s->st.flush = (void *) mem_flush;
916 /* open_internal4()-- Returns a stream structure from a character(kind=4)
920 open_internal4 (char *base, int length, gfc_offset offset)
924 s = get_mem (sizeof (unix_stream));
925 memset (s, '\0', sizeof (unix_stream));
928 s->buffer_offset = offset;
930 s->logical_offset = 0;
931 s->active = s->file_length = length;
933 s->st.close = (void *) mem_close;
934 s->st.seek = (void *) mem_seek;
935 s->st.tell = (void *) mem_tell;
936 /* buf_size is not a typo, we just reuse an identical
938 s->st.size = (void *) buf_size;
939 s->st.trunc = (void *) mem_truncate;
940 s->st.read = (void *) mem_read4;
941 s->st.write = (void *) mem_write4;
942 s->st.flush = (void *) mem_flush;
948 /* fd_to_stream()-- Given an open file descriptor, build a stream
952 fd_to_stream (int fd)
957 s = get_mem (sizeof (unix_stream));
958 memset (s, '\0', sizeof (unix_stream));
961 s->buffer_offset = 0;
962 s->physical_offset = 0;
963 s->logical_offset = 0;
965 /* Get the current length of the file. */
967 fstat (fd, &statbuf);
969 s->st_dev = statbuf.st_dev;
970 s->st_ino = statbuf.st_ino;
971 s->file_length = statbuf.st_size;
973 /* Only use buffered IO for regular files. */
974 if (S_ISREG (statbuf.st_mode)
975 && !options.all_unbuffered
976 && !(options.unbuffered_preconnected &&
977 (s->fd == STDIN_FILENO
978 || s->fd == STDOUT_FILENO
979 || s->fd == STDERR_FILENO)))
988 /* Given the Fortran unit number, convert it to a C file descriptor. */
991 unit_to_fd (int unit)
996 us = find_unit (unit);
1000 fd = ((unix_stream *) us->s)->fd;
1006 /* unpack_filename()-- Given a fortran string and a pointer to a
1007 * buffer that is PATH_MAX characters, convert the fortran string to a
1008 * C string in the buffer. Returns nonzero if this is not possible. */
1011 unpack_filename (char *cstring, const char *fstring, int len)
1013 if (fstring == NULL)
1015 len = fstrlen (fstring, len);
1016 if (len >= PATH_MAX)
1017 return ENAMETOOLONG;
1019 memmove (cstring, fstring, len);
1020 cstring[len] = '\0';
1026 /* tempfile()-- Generate a temporary filename for a scratch file and
1027 * open it. mkstemp() opens the file for reading and writing, but the
1028 * library mode prevents anything that is not allowed. The descriptor
1029 * is returned, which is -1 on error. The template is pointed to by
1030 * opp->file, which is copied into the unit structure
1031 * and freed later. */
1034 tempfile (st_parameter_open *opp)
1036 const char *tempdir;
1038 const char *slash = "/";
1042 #ifndef HAVE_MKSTEMP
1047 tempdir = getenv ("GFORTRAN_TMPDIR");
1049 if (tempdir == NULL)
1051 char buffer[MAX_PATH + 1];
1053 ret = GetTempPath (MAX_PATH, buffer);
1054 /* If we are not able to get a temp-directory, we use
1055 current directory. */
1056 if (ret > MAX_PATH || !ret)
1060 tempdir = strdup (buffer);
1063 if (tempdir == NULL)
1064 tempdir = getenv ("TMP");
1065 if (tempdir == NULL)
1066 tempdir = getenv ("TEMP");
1067 if (tempdir == NULL)
1068 tempdir = DEFAULT_TEMPDIR;
1071 /* Check for special case that tempdir contains slash
1072 or backslash at end. */
1073 tempdirlen = strlen (tempdir);
1074 if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1076 || tempdir[tempdirlen - 1] == '\\'
1081 // Take care that the template is longer in the mktemp() branch.
1082 template = get_mem (tempdirlen + 23);
1085 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1088 fd = mkstemp (template);
1090 #else /* HAVE_MKSTEMP */
1093 slashlen = strlen (slash);
1096 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1101 template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1103 template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1105 template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1110 if (!mktemp (template))
1117 #if defined(HAVE_CRLF) && defined(O_BINARY)
1118 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1119 S_IREAD | S_IWRITE);
1121 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1124 while (fd == -1 && errno == EEXIST);
1125 #endif /* HAVE_MKSTEMP */
1127 opp->file = template;
1128 opp->file_len = strlen (template); /* Don't include trailing nul */
1134 /* regular_file()-- Open a regular file.
1135 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1136 * unless an error occurs.
1137 * Returns the descriptor, which is less than zero on error. */
1140 regular_file (st_parameter_open *opp, unit_flags *flags)
1142 char path[min(PATH_MAX, opp->file_len + 1)];
1149 err = unpack_filename (path, opp->file, opp->file_len);
1152 errno = err; /* Fake an OS error */
1157 if (opp->file_len == 7)
1159 if (strncmp (path, "CONOUT$", 7) == 0
1160 || strncmp (path, "CONERR$", 7) == 0)
1162 fd = open ("/dev/conout", O_WRONLY);
1163 flags->action = ACTION_WRITE;
1168 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1170 fd = open ("/dev/conin", O_RDONLY);
1171 flags->action = ACTION_READ;
1178 if (opp->file_len == 7)
1180 if (strncmp (path, "CONOUT$", 7) == 0
1181 || strncmp (path, "CONERR$", 7) == 0)
1183 fd = open ("CONOUT$", O_WRONLY);
1184 flags->action = ACTION_WRITE;
1189 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1191 fd = open ("CONIN$", O_RDONLY);
1192 flags->action = ACTION_READ;
1199 switch (flags->action)
1209 case ACTION_READWRITE:
1210 case ACTION_UNSPECIFIED:
1215 internal_error (&opp->common, "regular_file(): Bad action");
1218 switch (flags->status)
1221 crflag = O_CREAT | O_EXCL;
1224 case STATUS_OLD: /* open will fail if the file does not exist*/
1228 case STATUS_UNKNOWN:
1229 case STATUS_SCRATCH:
1233 case STATUS_REPLACE:
1234 crflag = O_CREAT | O_TRUNC;
1238 internal_error (&opp->common, "regular_file(): Bad status");
1241 /* rwflag |= O_LARGEFILE; */
1243 #if defined(HAVE_CRLF) && defined(O_BINARY)
1247 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1248 fd = open (path, rwflag | crflag, mode);
1249 if (flags->action != ACTION_UNSPECIFIED)
1254 flags->action = ACTION_READWRITE;
1257 if (errno != EACCES && errno != EROFS)
1260 /* retry for read-only access */
1262 fd = open (path, rwflag | crflag, mode);
1265 flags->action = ACTION_READ;
1266 return fd; /* success */
1269 if (errno != EACCES)
1270 return fd; /* failure */
1272 /* retry for write-only access */
1274 fd = open (path, rwflag | crflag, mode);
1277 flags->action = ACTION_WRITE;
1278 return fd; /* success */
1280 return fd; /* failure */
1284 /* open_external()-- Open an external file, unix specific version.
1285 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1286 * Returns NULL on operating system error. */
1289 open_external (st_parameter_open *opp, unit_flags *flags)
1293 if (flags->status == STATUS_SCRATCH)
1295 fd = tempfile (opp);
1296 if (flags->action == ACTION_UNSPECIFIED)
1297 flags->action = ACTION_READWRITE;
1299 #if HAVE_UNLINK_OPEN_FILE
1300 /* We can unlink scratch files now and it will go away when closed. */
1307 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1309 fd = regular_file (opp, flags);
1316 return fd_to_stream (fd);
1320 /* input_stream()-- Return a stream pointer to the default input stream.
1321 * Called on initialization. */
1326 return fd_to_stream (STDIN_FILENO);
1330 /* output_stream()-- Return a stream pointer to the default output stream.
1331 * Called on initialization. */
1334 output_stream (void)
1338 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1339 setmode (STDOUT_FILENO, O_BINARY);
1342 s = fd_to_stream (STDOUT_FILENO);
1347 /* error_stream()-- Return a stream pointer to the default error stream.
1348 * Called on initialization. */
1355 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1356 setmode (STDERR_FILENO, O_BINARY);
1359 s = fd_to_stream (STDERR_FILENO);
1364 /* compare_file_filename()-- Given an open stream and a fortran string
1365 * that is a filename, figure out if the file is the same as the
1369 compare_file_filename (gfc_unit *u, const char *name, int len)
1371 char path[min(PATH_MAX, len + 1)];
1373 #ifdef HAVE_WORKING_STAT
1381 if (unpack_filename (path, name, len))
1382 return 0; /* Can't be the same */
1384 /* If the filename doesn't exist, then there is no match with the
1387 if (stat (path, &st) < 0)
1390 #ifdef HAVE_WORKING_STAT
1391 s = (unix_stream *) (u->s);
1392 return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1396 /* We try to match files by a unique ID. On some filesystems (network
1397 fs and FAT), we can't generate this unique ID, and will simply compare
1399 id1 = id_from_path (path);
1400 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1402 return (id1 == id2);
1405 if (len != u->file_len)
1407 return (memcmp(path, u->file, len) == 0);
1412 #ifdef HAVE_WORKING_STAT
1413 # define FIND_FILE0_DECL struct stat *st
1414 # define FIND_FILE0_ARGS st
1416 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1417 # define FIND_FILE0_ARGS id, file, file_len
1420 /* find_file0()-- Recursive work function for find_file() */
1423 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1426 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1433 #ifdef HAVE_WORKING_STAT
1436 unix_stream *s = (unix_stream *) (u->s);
1437 if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1442 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1449 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1453 v = find_file0 (u->left, FIND_FILE0_ARGS);
1457 v = find_file0 (u->right, FIND_FILE0_ARGS);
1465 /* find_file()-- Take the current filename and see if there is a unit
1466 * that has the file already open. Returns a pointer to the unit if so. */
1469 find_file (const char *file, gfc_charlen_type file_len)
1471 char path[min(PATH_MAX, file_len + 1)];
1474 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1478 if (unpack_filename (path, file, file_len))
1481 if (stat (path, &st[0]) < 0)
1484 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1485 id = id_from_path (path);
1488 __gthread_mutex_lock (&unit_lock);
1490 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1494 if (! __gthread_mutex_trylock (&u->lock))
1496 /* assert (u->closed == 0); */
1497 __gthread_mutex_unlock (&unit_lock);
1501 inc_waiting_locked (u);
1503 __gthread_mutex_unlock (&unit_lock);
1506 __gthread_mutex_lock (&u->lock);
1509 __gthread_mutex_lock (&unit_lock);
1510 __gthread_mutex_unlock (&u->lock);
1511 if (predec_waiting_locked (u) == 0)
1516 dec_waiting_unlocked (u);
1522 flush_all_units_1 (gfc_unit *u, int min_unit)
1526 if (u->unit_number > min_unit)
1528 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1532 if (u->unit_number >= min_unit)
1534 if (__gthread_mutex_trylock (&u->lock))
1538 __gthread_mutex_unlock (&u->lock);
1546 flush_all_units (void)
1551 __gthread_mutex_lock (&unit_lock);
1554 u = flush_all_units_1 (unit_root, min_unit);
1556 inc_waiting_locked (u);
1557 __gthread_mutex_unlock (&unit_lock);
1561 __gthread_mutex_lock (&u->lock);
1563 min_unit = u->unit_number + 1;
1568 __gthread_mutex_lock (&unit_lock);
1569 __gthread_mutex_unlock (&u->lock);
1570 (void) predec_waiting_locked (u);
1574 __gthread_mutex_lock (&unit_lock);
1575 __gthread_mutex_unlock (&u->lock);
1576 if (predec_waiting_locked (u) == 0)
1584 /* delete_file()-- Given a unit structure, delete the file associated
1585 * with the unit. Returns nonzero if something went wrong. */
1588 delete_file (gfc_unit * u)
1590 char path[min(PATH_MAX, u->file_len + 1)];
1591 int err = unpack_filename (path, u->file, u->file_len);
1594 { /* Shouldn't be possible */
1599 return unlink (path);
1603 /* file_exists()-- Returns nonzero if the current filename exists on
1607 file_exists (const char *file, gfc_charlen_type file_len)
1609 char path[min(PATH_MAX, file_len + 1)];
1611 if (unpack_filename (path, file, file_len))
1614 return !(access (path, F_OK));
1618 /* file_size()-- Returns the size of the file. */
1621 file_size (const char *file, gfc_charlen_type file_len)
1623 char path[min(PATH_MAX, file_len + 1)];
1624 struct stat statbuf;
1626 if (unpack_filename (path, file, file_len))
1629 if (stat (path, &statbuf) < 0)
1632 return (GFC_IO_INT) statbuf.st_size;
1635 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1637 /* inquire_sequential()-- Given a fortran string, determine if the
1638 * file is suitable for sequential access. Returns a C-style
1642 inquire_sequential (const char *string, int len)
1644 char path[min(PATH_MAX, len + 1)];
1645 struct stat statbuf;
1647 if (string == NULL ||
1648 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1651 if (S_ISREG (statbuf.st_mode) ||
1652 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1655 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1662 /* inquire_direct()-- Given a fortran string, determine if the file is
1663 * suitable for direct access. Returns a C-style string. */
1666 inquire_direct (const char *string, int len)
1668 char path[min(PATH_MAX, len + 1)];
1669 struct stat statbuf;
1671 if (string == NULL ||
1672 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1675 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1678 if (S_ISDIR (statbuf.st_mode) ||
1679 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1686 /* inquire_formatted()-- Given a fortran string, determine if the file
1687 * is suitable for formatted form. Returns a C-style string. */
1690 inquire_formatted (const char *string, int len)
1692 char path[min(PATH_MAX, len + 1)];
1693 struct stat statbuf;
1695 if (string == NULL ||
1696 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1699 if (S_ISREG (statbuf.st_mode) ||
1700 S_ISBLK (statbuf.st_mode) ||
1701 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1704 if (S_ISDIR (statbuf.st_mode))
1711 /* inquire_unformatted()-- Given a fortran string, determine if the file
1712 * is suitable for unformatted form. Returns a C-style string. */
1715 inquire_unformatted (const char *string, int len)
1717 return inquire_formatted (string, len);
1721 /* inquire_access()-- Given a fortran string, determine if the file is
1722 * suitable for access. */
1725 inquire_access (const char *string, int len, int mode)
1727 char path[min(PATH_MAX, len + 1)];
1729 if (string == NULL || unpack_filename (path, string, len) ||
1730 access (path, mode) < 0)
1737 /* inquire_read()-- Given a fortran string, determine if the file is
1738 * suitable for READ access. */
1741 inquire_read (const char *string, int len)
1743 return inquire_access (string, len, R_OK);
1747 /* inquire_write()-- Given a fortran string, determine if the file is
1748 * suitable for READ access. */
1751 inquire_write (const char *string, int len)
1753 return inquire_access (string, len, W_OK);
1757 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1758 * suitable for read and write access. */
1761 inquire_readwrite (const char *string, int len)
1763 return inquire_access (string, len, R_OK | W_OK);
1768 stream_isatty (stream *s)
1770 return isatty (((unix_stream *) s)->fd);
1774 stream_ttyname (stream *s __attribute__ ((unused)),
1775 char * buf __attribute__ ((unused)),
1776 size_t buflen __attribute__ ((unused)))
1778 #ifdef HAVE_TTYNAME_R
1779 return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1780 #elif defined HAVE_TTYNAME
1783 p = ttyname (((unix_stream *) s)->fd);
1789 memcpy (buf, p, plen);
1799 /* How files are stored: This is an operating-system specific issue,
1800 and therefore belongs here. There are three cases to consider.
1803 Records are written as block of bytes corresponding to the record
1804 length of the file. This goes for both formatted and unformatted
1805 records. Positioning is done explicitly for each data transfer,
1806 so positioning is not much of an issue.
1808 Sequential Formatted:
1809 Records are separated by newline characters. The newline character
1810 is prohibited from appearing in a string. If it does, this will be
1811 messed up on the next read. End of file is also the end of a record.
1813 Sequential Unformatted:
1814 In this case, we are merely copying bytes to and from main storage,
1815 yet we need to keep track of varying record lengths. We adopt
1816 the solution used by f2c. Each record contains a pair of length
1819 Length of record n in bytes
1821 Length of record n in bytes
1823 Length of record n+1 in bytes
1825 Length of record n+1 in bytes
1827 The length is stored at the end of a record to allow backspacing to the
1828 previous record. Between data transfer statements, the file pointer
1829 is left pointing to the first length of the current record.
1831 ENDFILE records are never explicitly stored.