1 /* Copyright (C) 2002-2013 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran 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 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 /* Unix stream I/O module */
42 /* min macro that evaluates its arguments only once. */
44 ({ typeof (a) _a = (a); \
45 typeof (b) _b = (b); \
49 /* For mingw, we don't identify files by their inode number, but by a
50 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
53 #define WIN32_LEAN_AND_MEAN
56 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
58 #define lseek _lseeki64
60 #define fstat _fstati64
65 #ifndef HAVE_WORKING_STAT
67 id_from_handle (HANDLE hFile)
69 BY_HANDLE_FILE_INFORMATION FileInformation;
71 if (hFile == INVALID_HANDLE_VALUE)
74 memset (&FileInformation, 0, sizeof(FileInformation));
75 if (!GetFileInformationByHandle (hFile, &FileInformation))
78 return ((uint64_t) FileInformation.nFileIndexLow)
79 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
84 id_from_path (const char *path)
89 if (!path || !*path || access (path, F_OK))
92 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
93 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
95 res = id_from_handle (hFile);
102 id_from_fd (const int fd)
104 return id_from_handle ((HANDLE) _get_osfhandle (fd));
111 #define PATH_MAX 1024
114 /* These flags aren't defined on all targets (mingw32), so provide them
147 /* Fallback implementation of access() on systems that don't have it.
148 Only modes R_OK, W_OK and F_OK are used in this file. */
151 fallback_access (const char *path, int mode)
155 if ((mode & R_OK) && (fd = open (path, O_RDONLY)) < 0)
159 if ((mode & W_OK) && (fd = open (path, O_WRONLY)) < 0)
166 return stat (path, &st);
173 #define access fallback_access
177 /* Unix and internal stream I/O module */
179 static const int BUFFER_SIZE = 8192;
185 gfc_offset buffer_offset; /* File offset of the start of the buffer */
186 gfc_offset physical_offset; /* Current physical file offset */
187 gfc_offset logical_offset; /* Current logical file offset */
188 gfc_offset file_length; /* Length of the file. */
190 char *buffer; /* Pointer to the buffer. */
191 int fd; /* The POSIX file descriptor. */
193 int active; /* Length of valid bytes in the buffer */
195 int ndirty; /* Dirty bytes starting at buffer_offset */
197 /* Cached stat(2) values. */
204 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
205 * standard descriptors, returning a non-standard descriptor. If the
206 * user specifies that system errors should go to standard output,
207 * then closes standard output, we don't want the system errors to a
208 * file that has been given file descriptor 1 or 0. We want to send
209 * the error to the invalid descriptor. */
215 int input, output, error;
217 input = output = error = 0;
219 /* Unix allocates the lowest descriptors first, so a loop is not
220 required, but this order is. */
221 if (fd == STDIN_FILENO)
226 if (fd == STDOUT_FILENO)
231 if (fd == STDERR_FILENO)
238 close (STDIN_FILENO);
240 close (STDOUT_FILENO);
242 close (STDERR_FILENO);
249 /* If the stream corresponds to a preconnected unit, we flush the
250 corresponding C stream. This is bugware for mixed C-Fortran codes
251 where the C code doesn't flush I/O before returning. */
253 flush_if_preconnected (stream * s)
257 fd = ((unix_stream *) s)->fd;
258 if (fd == STDIN_FILENO)
260 else if (fd == STDOUT_FILENO)
262 else if (fd == STDERR_FILENO)
267 /********************************************************************
268 Raw I/O functions (read, write, seek, tell, truncate, close).
270 These functions wrap the basic POSIX I/O syscalls. Any deviation in
271 semantics is a bug, except the following: write restarts in case
272 of being interrupted by a signal, and as the first argument the
273 functions take the unix_stream struct rather than an integer file
274 descriptor. Also, for POSIX read() and write() a nbyte argument larger
275 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
276 than size_t as for POSIX read/write.
277 *********************************************************************/
280 raw_flush (unix_stream * s __attribute__ ((unused)))
286 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
288 /* For read we can't do I/O in a loop like raw_write does, because
289 that will break applications that wait for interactive I/O. */
290 return read (s->fd, buf, nbyte);
294 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
296 ssize_t trans, bytes_left;
300 buf_st = (char *) buf;
302 /* We must write in a loop since some systems don't restart system
303 calls in case of a signal. */
304 while (bytes_left > 0)
306 trans = write (s->fd, buf_st, bytes_left);
318 return nbyte - bytes_left;
322 raw_seek (unix_stream * s, gfc_offset offset, int whence)
324 return lseek (s->fd, offset, whence);
328 raw_tell (unix_stream * s)
330 return lseek (s->fd, 0, SEEK_CUR);
334 raw_size (unix_stream * s)
337 int ret = fstat (s->fd, &statbuf);
340 if (S_ISREG (statbuf.st_mode))
341 return statbuf.st_size;
347 raw_truncate (unix_stream * s, gfc_offset length)
358 h = (HANDLE) _get_osfhandle (s->fd);
359 if (h == INVALID_HANDLE_VALUE)
364 cur = lseek (s->fd, 0, SEEK_CUR);
367 if (lseek (s->fd, length, SEEK_SET) == -1)
369 if (!SetEndOfFile (h))
374 if (lseek (s->fd, cur, SEEK_SET) == -1)
378 lseek (s->fd, cur, SEEK_SET);
380 #elif defined HAVE_FTRUNCATE
381 return ftruncate (s->fd, length);
382 #elif defined HAVE_CHSIZE
383 return chsize (s->fd, length);
385 runtime_error ("required ftruncate or chsize support not present");
391 raw_close (unix_stream * s)
395 if (s->fd != STDOUT_FILENO
396 && s->fd != STDERR_FILENO
397 && s->fd != STDIN_FILENO)
398 retval = close (s->fd);
406 raw_init (unix_stream * s)
408 s->st.read = (void *) raw_read;
409 s->st.write = (void *) raw_write;
410 s->st.seek = (void *) raw_seek;
411 s->st.tell = (void *) raw_tell;
412 s->st.size = (void *) raw_size;
413 s->st.trunc = (void *) raw_truncate;
414 s->st.close = (void *) raw_close;
415 s->st.flush = (void *) raw_flush;
422 /*********************************************************************
423 Buffered I/O functions. These functions have the same semantics as the
424 raw I/O functions above, except that they are buffered in order to
425 improve performance. The buffer must be flushed when switching from
426 reading to writing and vice versa. Only supported for regular files.
427 *********************************************************************/
430 buf_flush (unix_stream * s)
434 /* Flushing in read mode means discarding read bytes. */
440 if (s->physical_offset != s->buffer_offset
441 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
444 writelen = raw_write (s, s->buffer, s->ndirty);
446 s->physical_offset = s->buffer_offset + writelen;
448 if (s->physical_offset > s->file_length)
449 s->file_length = s->physical_offset;
451 s->ndirty -= writelen;
459 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
462 s->buffer_offset = s->logical_offset;
464 /* Is the data we want in the buffer? */
465 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
466 && s->buffer_offset <= s->logical_offset)
467 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
470 /* First copy the active bytes if applicable, then read the rest
471 either directly or filling the buffer. */
474 ssize_t to_read, did_read;
475 gfc_offset new_logical;
478 if (s->logical_offset >= s->buffer_offset
479 && s->buffer_offset + s->active >= s->logical_offset)
481 nread = s->active - (s->logical_offset - s->buffer_offset);
482 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
486 /* At this point we consider all bytes in the buffer discarded. */
487 to_read = nbyte - nread;
488 new_logical = s->logical_offset + nread;
489 if (s->physical_offset != new_logical
490 && lseek (s->fd, new_logical, SEEK_SET) < 0)
492 s->buffer_offset = s->physical_offset = new_logical;
493 if (to_read <= BUFFER_SIZE/2)
495 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
496 s->physical_offset += did_read;
497 s->active = did_read;
498 did_read = (did_read > to_read) ? to_read : did_read;
499 memcpy (p, s->buffer, did_read);
503 did_read = raw_read (s, p, to_read);
504 s->physical_offset += did_read;
507 nbyte = did_read + nread;
509 s->logical_offset += nbyte;
514 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
517 s->buffer_offset = s->logical_offset;
519 /* Does the data fit into the buffer? As a special case, if the
520 buffer is empty and the request is bigger than BUFFER_SIZE/2,
521 write directly. This avoids the case where the buffer would have
522 to be flushed at every write. */
523 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
524 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
525 && s->buffer_offset <= s->logical_offset
526 && s->buffer_offset + s->ndirty >= s->logical_offset)
528 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
529 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
535 /* Flush, and either fill the buffer with the new data, or if
536 the request is bigger than the buffer size, write directly
537 bypassing the buffer. */
539 if (nbyte <= BUFFER_SIZE/2)
541 memcpy (s->buffer, buf, nbyte);
542 s->buffer_offset = s->logical_offset;
547 if (s->physical_offset != s->logical_offset)
549 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
551 s->physical_offset = s->logical_offset;
554 nbyte = raw_write (s, buf, nbyte);
555 s->physical_offset += nbyte;
558 s->logical_offset += nbyte;
559 if (s->logical_offset > s->file_length)
560 s->file_length = s->logical_offset;
565 buf_seek (unix_stream * s, gfc_offset offset, int whence)
572 offset += s->logical_offset;
575 offset += s->file_length;
585 s->logical_offset = offset;
590 buf_tell (unix_stream * s)
592 return buf_seek (s, 0, SEEK_CUR);
596 buf_size (unix_stream * s)
598 return s->file_length;
602 buf_truncate (unix_stream * s, gfc_offset length)
606 if (buf_flush (s) != 0)
608 r = raw_truncate (s, length);
610 s->file_length = length;
615 buf_close (unix_stream * s)
617 if (buf_flush (s) != 0)
620 return raw_close (s);
624 buf_init (unix_stream * s)
626 s->st.read = (void *) buf_read;
627 s->st.write = (void *) buf_write;
628 s->st.seek = (void *) buf_seek;
629 s->st.tell = (void *) buf_tell;
630 s->st.size = (void *) buf_size;
631 s->st.trunc = (void *) buf_truncate;
632 s->st.close = (void *) buf_close;
633 s->st.flush = (void *) buf_flush;
635 s->buffer = get_mem (BUFFER_SIZE);
640 /*********************************************************************
641 memory stream functions - These are used for internal files
643 The idea here is that a single stream structure is created and all
644 requests must be satisfied from it. The location and size of the
645 buffer is the character variable supplied to the READ or WRITE
648 *********************************************************************/
651 mem_alloc_r (stream * strm, int * len)
653 unix_stream * s = (unix_stream *) strm;
655 gfc_offset where = s->logical_offset;
657 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
660 n = s->buffer_offset + s->active - where;
664 s->logical_offset = where + *len;
666 return s->buffer + (where - s->buffer_offset);
671 mem_alloc_r4 (stream * strm, int * len)
673 unix_stream * s = (unix_stream *) strm;
675 gfc_offset where = s->logical_offset;
677 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
680 n = s->buffer_offset + s->active - where;
684 s->logical_offset = where + *len;
686 return s->buffer + (where - s->buffer_offset) * 4;
691 mem_alloc_w (stream * strm, int * len)
693 unix_stream * s = (unix_stream *) strm;
695 gfc_offset where = s->logical_offset;
699 if (where < s->buffer_offset)
702 if (m > s->file_length)
705 s->logical_offset = m;
707 return s->buffer + (where - s->buffer_offset);
712 mem_alloc_w4 (stream * strm, int * len)
714 unix_stream * s = (unix_stream *) strm;
716 gfc_offset where = s->logical_offset;
717 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
721 if (where < s->buffer_offset)
724 if (m > s->file_length)
727 s->logical_offset = m;
728 return &result[where - s->buffer_offset];
732 /* Stream read function for character(kine=1) internal units. */
735 mem_read (stream * s, void * buf, ssize_t nbytes)
740 p = mem_alloc_r (s, &nb);
751 /* Stream read function for chracter(kind=4) internal units. */
754 mem_read4 (stream * s, void * buf, ssize_t nbytes)
759 p = mem_alloc_r (s, &nb);
770 /* Stream write function for character(kind=1) internal units. */
773 mem_write (stream * s, const void * buf, ssize_t nbytes)
778 p = mem_alloc_w (s, &nb);
789 /* Stream write function for character(kind=4) internal units. */
792 mem_write4 (stream * s, const void * buf, ssize_t nwords)
797 p = mem_alloc_w4 (s, &nw);
801 *p++ = (gfc_char4_t) *((char *) buf);
810 mem_seek (stream * strm, gfc_offset offset, int whence)
812 unix_stream * s = (unix_stream *) strm;
818 offset += s->logical_offset;
821 offset += s->file_length;
827 /* Note that for internal array I/O it's actually possible to have a
828 negative offset, so don't check for that. */
829 if (offset > s->file_length)
835 s->logical_offset = offset;
837 /* Returning < 0 is the error indicator for sseek(), so return 0 if
838 offset is negative. Thus if the return value is 0, the caller
839 has to use stell() to get the real value of logical_offset. */
847 mem_tell (stream * s)
849 return ((unix_stream *)s)->logical_offset;
854 mem_truncate (unix_stream * s __attribute__ ((unused)),
855 gfc_offset length __attribute__ ((unused)))
862 mem_flush (unix_stream * s __attribute__ ((unused)))
869 mem_close (unix_stream * s)
877 /*********************************************************************
878 Public functions -- A reimplementation of this module needs to
879 define functional equivalents of the following.
880 *********************************************************************/
882 /* open_internal()-- Returns a stream structure from a character(kind=1)
886 open_internal (char *base, int length, gfc_offset offset)
890 s = get_mem (sizeof (unix_stream));
891 memset (s, '\0', sizeof (unix_stream));
894 s->buffer_offset = offset;
896 s->logical_offset = 0;
897 s->active = s->file_length = length;
899 s->st.close = (void *) mem_close;
900 s->st.seek = (void *) mem_seek;
901 s->st.tell = (void *) mem_tell;
902 /* buf_size is not a typo, we just reuse an identical
904 s->st.size = (void *) buf_size;
905 s->st.trunc = (void *) mem_truncate;
906 s->st.read = (void *) mem_read;
907 s->st.write = (void *) mem_write;
908 s->st.flush = (void *) mem_flush;
913 /* open_internal4()-- Returns a stream structure from a character(kind=4)
917 open_internal4 (char *base, int length, gfc_offset offset)
921 s = get_mem (sizeof (unix_stream));
922 memset (s, '\0', sizeof (unix_stream));
925 s->buffer_offset = offset;
927 s->logical_offset = 0;
928 s->active = s->file_length = length;
930 s->st.close = (void *) mem_close;
931 s->st.seek = (void *) mem_seek;
932 s->st.tell = (void *) mem_tell;
933 /* buf_size is not a typo, we just reuse an identical
935 s->st.size = (void *) buf_size;
936 s->st.trunc = (void *) mem_truncate;
937 s->st.read = (void *) mem_read4;
938 s->st.write = (void *) mem_write4;
939 s->st.flush = (void *) mem_flush;
945 /* fd_to_stream()-- Given an open file descriptor, build a stream
949 fd_to_stream (int fd)
954 s = get_mem (sizeof (unix_stream));
955 memset (s, '\0', sizeof (unix_stream));
958 s->buffer_offset = 0;
959 s->physical_offset = 0;
960 s->logical_offset = 0;
962 /* Get the current length of the file. */
964 fstat (fd, &statbuf);
966 s->st_dev = statbuf.st_dev;
967 s->st_ino = statbuf.st_ino;
968 s->file_length = statbuf.st_size;
970 /* Only use buffered IO for regular files. */
971 if (S_ISREG (statbuf.st_mode)
972 && !options.all_unbuffered
973 && !(options.unbuffered_preconnected &&
974 (s->fd == STDIN_FILENO
975 || s->fd == STDOUT_FILENO
976 || s->fd == STDERR_FILENO)))
985 /* Given the Fortran unit number, convert it to a C file descriptor. */
988 unit_to_fd (int unit)
993 us = find_unit (unit);
997 fd = ((unix_stream *) us->s)->fd;
1003 /* unpack_filename()-- Given a fortran string and a pointer to a
1004 * buffer that is PATH_MAX characters, convert the fortran string to a
1005 * C string in the buffer. Returns nonzero if this is not possible. */
1008 unpack_filename (char *cstring, const char *fstring, int len)
1010 if (fstring == NULL)
1012 len = fstrlen (fstring, len);
1013 if (len >= PATH_MAX)
1014 return ENAMETOOLONG;
1016 memmove (cstring, fstring, len);
1017 cstring[len] = '\0';
1023 /* tempfile()-- Generate a temporary filename for a scratch file and
1024 * open it. mkstemp() opens the file for reading and writing, but the
1025 * library mode prevents anything that is not allowed. The descriptor
1026 * is returned, which is -1 on error. The template is pointed to by
1027 * opp->file, which is copied into the unit structure
1028 * and freed later. */
1031 tempfile (st_parameter_open *opp)
1033 const char *tempdir;
1035 const char *slash = "/";
1039 #ifndef HAVE_MKSTEMP
1044 tempdir = getenv ("GFORTRAN_TMPDIR");
1046 if (tempdir == NULL)
1048 char buffer[MAX_PATH + 1];
1050 ret = GetTempPath (MAX_PATH, buffer);
1051 /* If we are not able to get a temp-directory, we use
1052 current directory. */
1053 if (ret > MAX_PATH || !ret)
1057 tempdir = strdup (buffer);
1060 if (tempdir == NULL)
1061 tempdir = getenv ("TMP");
1062 if (tempdir == NULL)
1063 tempdir = getenv ("TEMP");
1064 if (tempdir == NULL)
1065 tempdir = DEFAULT_TEMPDIR;
1068 /* Check for special case that tempdir contains slash
1069 or backslash at end. */
1070 tempdirlen = strlen (tempdir);
1071 if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1073 || tempdir[tempdirlen - 1] == '\\'
1078 // Take care that the template is longer in the mktemp() branch.
1079 template = get_mem (tempdirlen + 23);
1082 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1085 fd = mkstemp (template);
1087 #else /* HAVE_MKSTEMP */
1090 slashlen = strlen (slash);
1093 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1098 template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1100 template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1102 template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1107 if (!mktemp (template))
1114 #if defined(HAVE_CRLF) && defined(O_BINARY)
1115 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1118 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR);
1121 while (fd == -1 && errno == EEXIST);
1122 #endif /* HAVE_MKSTEMP */
1124 opp->file = template;
1125 opp->file_len = strlen (template); /* Don't include trailing nul */
1131 /* regular_file()-- Open a regular file.
1132 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1133 * unless an error occurs.
1134 * Returns the descriptor, which is less than zero on error. */
1137 regular_file (st_parameter_open *opp, unit_flags *flags)
1139 char path[min(PATH_MAX, opp->file_len + 1)];
1146 err = unpack_filename (path, opp->file, opp->file_len);
1149 errno = err; /* Fake an OS error */
1154 if (opp->file_len == 7)
1156 if (strncmp (path, "CONOUT$", 7) == 0
1157 || strncmp (path, "CONERR$", 7) == 0)
1159 fd = open ("/dev/conout", O_WRONLY);
1160 flags->action = ACTION_WRITE;
1165 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1167 fd = open ("/dev/conin", O_RDONLY);
1168 flags->action = ACTION_READ;
1175 if (opp->file_len == 7)
1177 if (strncmp (path, "CONOUT$", 7) == 0
1178 || strncmp (path, "CONERR$", 7) == 0)
1180 fd = open ("CONOUT$", O_WRONLY);
1181 flags->action = ACTION_WRITE;
1186 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1188 fd = open ("CONIN$", O_RDONLY);
1189 flags->action = ACTION_READ;
1196 switch (flags->action)
1206 case ACTION_READWRITE:
1207 case ACTION_UNSPECIFIED:
1212 internal_error (&opp->common, "regular_file(): Bad action");
1215 switch (flags->status)
1218 crflag = O_CREAT | O_EXCL;
1221 case STATUS_OLD: /* open will fail if the file does not exist*/
1225 case STATUS_UNKNOWN:
1226 case STATUS_SCRATCH:
1230 case STATUS_REPLACE:
1231 crflag = O_CREAT | O_TRUNC;
1235 internal_error (&opp->common, "regular_file(): Bad status");
1238 /* rwflag |= O_LARGEFILE; */
1240 #if defined(HAVE_CRLF) && defined(O_BINARY)
1244 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1245 fd = open (path, rwflag | crflag, mode);
1246 if (flags->action != ACTION_UNSPECIFIED)
1251 flags->action = ACTION_READWRITE;
1254 if (errno != EACCES && errno != EROFS)
1257 /* retry for read-only access */
1259 fd = open (path, rwflag | crflag, mode);
1262 flags->action = ACTION_READ;
1263 return fd; /* success */
1266 if (errno != EACCES)
1267 return fd; /* failure */
1269 /* retry for write-only access */
1271 fd = open (path, rwflag | crflag, mode);
1274 flags->action = ACTION_WRITE;
1275 return fd; /* success */
1277 return fd; /* failure */
1281 /* open_external()-- Open an external file, unix specific version.
1282 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1283 * Returns NULL on operating system error. */
1286 open_external (st_parameter_open *opp, unit_flags *flags)
1290 if (flags->status == STATUS_SCRATCH)
1292 fd = tempfile (opp);
1293 if (flags->action == ACTION_UNSPECIFIED)
1294 flags->action = ACTION_READWRITE;
1296 #if HAVE_UNLINK_OPEN_FILE
1297 /* We can unlink scratch files now and it will go away when closed. */
1304 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1306 fd = regular_file (opp, flags);
1313 return fd_to_stream (fd);
1317 /* input_stream()-- Return a stream pointer to the default input stream.
1318 * Called on initialization. */
1323 return fd_to_stream (STDIN_FILENO);
1327 /* output_stream()-- Return a stream pointer to the default output stream.
1328 * Called on initialization. */
1331 output_stream (void)
1335 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1336 setmode (STDOUT_FILENO, O_BINARY);
1339 s = fd_to_stream (STDOUT_FILENO);
1344 /* error_stream()-- Return a stream pointer to the default error stream.
1345 * Called on initialization. */
1352 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1353 setmode (STDERR_FILENO, O_BINARY);
1356 s = fd_to_stream (STDERR_FILENO);
1361 /* compare_file_filename()-- Given an open stream and a fortran string
1362 * that is a filename, figure out if the file is the same as the
1366 compare_file_filename (gfc_unit *u, const char *name, int len)
1368 char path[min(PATH_MAX, len + 1)];
1370 #ifdef HAVE_WORKING_STAT
1378 if (unpack_filename (path, name, len))
1379 return 0; /* Can't be the same */
1381 /* If the filename doesn't exist, then there is no match with the
1384 if (stat (path, &st) < 0)
1387 #ifdef HAVE_WORKING_STAT
1388 s = (unix_stream *) (u->s);
1389 return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1393 /* We try to match files by a unique ID. On some filesystems (network
1394 fs and FAT), we can't generate this unique ID, and will simply compare
1396 id1 = id_from_path (path);
1397 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1399 return (id1 == id2);
1402 if (len != u->file_len)
1404 return (memcmp(path, u->file, len) == 0);
1409 #ifdef HAVE_WORKING_STAT
1410 # define FIND_FILE0_DECL struct stat *st
1411 # define FIND_FILE0_ARGS st
1413 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1414 # define FIND_FILE0_ARGS id, file, file_len
1417 /* find_file0()-- Recursive work function for find_file() */
1420 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1423 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1430 #ifdef HAVE_WORKING_STAT
1433 unix_stream *s = (unix_stream *) (u->s);
1434 if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1439 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1446 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1450 v = find_file0 (u->left, FIND_FILE0_ARGS);
1454 v = find_file0 (u->right, FIND_FILE0_ARGS);
1462 /* find_file()-- Take the current filename and see if there is a unit
1463 * that has the file already open. Returns a pointer to the unit if so. */
1466 find_file (const char *file, gfc_charlen_type file_len)
1468 char path[min(PATH_MAX, file_len + 1)];
1471 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1475 if (unpack_filename (path, file, file_len))
1478 if (stat (path, &st[0]) < 0)
1481 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1482 id = id_from_path (path);
1485 __gthread_mutex_lock (&unit_lock);
1487 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1491 if (! __gthread_mutex_trylock (&u->lock))
1493 /* assert (u->closed == 0); */
1494 __gthread_mutex_unlock (&unit_lock);
1498 inc_waiting_locked (u);
1500 __gthread_mutex_unlock (&unit_lock);
1503 __gthread_mutex_lock (&u->lock);
1506 __gthread_mutex_lock (&unit_lock);
1507 __gthread_mutex_unlock (&u->lock);
1508 if (predec_waiting_locked (u) == 0)
1513 dec_waiting_unlocked (u);
1519 /* Flush dirty data, making sure that OS metadata is updated as
1520 well. Note that this is VERY slow on mingw due to committing data
1521 to stable storage. */
1523 flush_sync (stream * s)
1525 if (sflush (s) == -1)
1528 if (_commit (((unix_stream *)s)->fd) == -1)
1536 flush_all_units_1 (gfc_unit *u, int min_unit)
1540 if (u->unit_number > min_unit)
1542 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1546 if (u->unit_number >= min_unit)
1548 if (__gthread_mutex_trylock (&u->lock))
1552 __gthread_mutex_unlock (&u->lock);
1560 flush_all_units (void)
1565 __gthread_mutex_lock (&unit_lock);
1568 u = flush_all_units_1 (unit_root, min_unit);
1570 inc_waiting_locked (u);
1571 __gthread_mutex_unlock (&unit_lock);
1575 __gthread_mutex_lock (&u->lock);
1577 min_unit = u->unit_number + 1;
1582 __gthread_mutex_lock (&unit_lock);
1583 __gthread_mutex_unlock (&u->lock);
1584 (void) predec_waiting_locked (u);
1588 __gthread_mutex_lock (&unit_lock);
1589 __gthread_mutex_unlock (&u->lock);
1590 if (predec_waiting_locked (u) == 0)
1598 /* delete_file()-- Given a unit structure, delete the file associated
1599 * with the unit. Returns nonzero if something went wrong. */
1602 delete_file (gfc_unit * u)
1604 char path[min(PATH_MAX, u->file_len + 1)];
1605 int err = unpack_filename (path, u->file, u->file_len);
1608 { /* Shouldn't be possible */
1613 return unlink (path);
1617 /* file_exists()-- Returns nonzero if the current filename exists on
1621 file_exists (const char *file, gfc_charlen_type file_len)
1623 char path[min(PATH_MAX, file_len + 1)];
1625 if (unpack_filename (path, file, file_len))
1628 return !(access (path, F_OK));
1632 /* file_size()-- Returns the size of the file. */
1635 file_size (const char *file, gfc_charlen_type file_len)
1637 char path[min(PATH_MAX, file_len + 1)];
1638 struct stat statbuf;
1640 if (unpack_filename (path, file, file_len))
1643 if (stat (path, &statbuf) < 0)
1646 return (GFC_IO_INT) statbuf.st_size;
1649 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1651 /* inquire_sequential()-- Given a fortran string, determine if the
1652 * file is suitable for sequential access. Returns a C-style
1656 inquire_sequential (const char *string, int len)
1658 char path[min(PATH_MAX, len + 1)];
1659 struct stat statbuf;
1661 if (string == NULL ||
1662 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1665 if (S_ISREG (statbuf.st_mode) ||
1666 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1669 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1676 /* inquire_direct()-- Given a fortran string, determine if the file is
1677 * suitable for direct access. Returns a C-style string. */
1680 inquire_direct (const char *string, int len)
1682 char path[min(PATH_MAX, len + 1)];
1683 struct stat statbuf;
1685 if (string == NULL ||
1686 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1689 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1692 if (S_ISDIR (statbuf.st_mode) ||
1693 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1700 /* inquire_formatted()-- Given a fortran string, determine if the file
1701 * is suitable for formatted form. Returns a C-style string. */
1704 inquire_formatted (const char *string, int len)
1706 char path[min(PATH_MAX, len + 1)];
1707 struct stat statbuf;
1709 if (string == NULL ||
1710 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1713 if (S_ISREG (statbuf.st_mode) ||
1714 S_ISBLK (statbuf.st_mode) ||
1715 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1718 if (S_ISDIR (statbuf.st_mode))
1725 /* inquire_unformatted()-- Given a fortran string, determine if the file
1726 * is suitable for unformatted form. Returns a C-style string. */
1729 inquire_unformatted (const char *string, int len)
1731 return inquire_formatted (string, len);
1735 /* inquire_access()-- Given a fortran string, determine if the file is
1736 * suitable for access. */
1739 inquire_access (const char *string, int len, int mode)
1741 char path[min(PATH_MAX, len + 1)];
1743 if (string == NULL || unpack_filename (path, string, len) ||
1744 access (path, mode) < 0)
1751 /* inquire_read()-- Given a fortran string, determine if the file is
1752 * suitable for READ access. */
1755 inquire_read (const char *string, int len)
1757 return inquire_access (string, len, R_OK);
1761 /* inquire_write()-- Given a fortran string, determine if the file is
1762 * suitable for READ access. */
1765 inquire_write (const char *string, int len)
1767 return inquire_access (string, len, W_OK);
1771 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1772 * suitable for read and write access. */
1775 inquire_readwrite (const char *string, int len)
1777 return inquire_access (string, len, R_OK | W_OK);
1782 stream_isatty (stream *s)
1784 return isatty (((unix_stream *) s)->fd);
1788 stream_ttyname (stream *s __attribute__ ((unused)),
1789 char * buf __attribute__ ((unused)),
1790 size_t buflen __attribute__ ((unused)))
1792 #ifdef HAVE_TTYNAME_R
1793 return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1794 #elif defined HAVE_TTYNAME
1797 p = ttyname (((unix_stream *) s)->fd);
1803 memcpy (buf, p, plen);
1813 /* How files are stored: This is an operating-system specific issue,
1814 and therefore belongs here. There are three cases to consider.
1817 Records are written as block of bytes corresponding to the record
1818 length of the file. This goes for both formatted and unformatted
1819 records. Positioning is done explicitly for each data transfer,
1820 so positioning is not much of an issue.
1822 Sequential Formatted:
1823 Records are separated by newline characters. The newline character
1824 is prohibited from appearing in a string. If it does, this will be
1825 messed up on the next read. End of file is also the end of a record.
1827 Sequential Unformatted:
1828 In this case, we are merely copying bytes to and from main storage,
1829 yet we need to keep track of varying record lengths. We adopt
1830 the solution used by f2c. Each record contains a pair of length
1833 Length of record n in bytes
1835 Length of record n in bytes
1837 Length of record n+1 in bytes
1839 Length of record n+1 in bytes
1841 The length is stored at the end of a record to allow backspacing to the
1842 previous record. Between data transfer statements, the file pointer
1843 is left pointing to the first length of the current record.
1845 ENDFILE records are never explicitly stored.