1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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 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 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 /* Unix stream I/O module */
43 /* For mingw, we don't identify files by their inode number, but by a
44 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
47 #define WIN32_LEAN_AND_MEAN
50 #define lseek _lseeki64
51 #define fstat _fstati64
53 typedef struct _stati64 gfstat_t;
55 #ifndef HAVE_WORKING_STAT
57 id_from_handle (HANDLE hFile)
59 BY_HANDLE_FILE_INFORMATION FileInformation;
61 if (hFile == INVALID_HANDLE_VALUE)
64 memset (&FileInformation, 0, sizeof(FileInformation));
65 if (!GetFileInformationByHandle (hFile, &FileInformation))
68 return ((uint64_t) FileInformation.nFileIndexLow)
69 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
74 id_from_path (const char *path)
79 if (!path || !*path || access (path, F_OK))
82 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
83 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
85 res = id_from_handle (hFile);
92 id_from_fd (const int fd)
94 return id_from_handle ((HANDLE) _get_osfhandle (fd));
100 typedef struct stat gfstat_t;
104 #define PATH_MAX 1024
107 /* These flags aren't defined on all targets (mingw32), so provide them
140 /* Fallback implementation of access() on systems that don't have it.
141 Only modes R_OK, W_OK and F_OK are used in this file. */
144 fallback_access (const char *path, int mode)
146 if ((mode & R_OK) && open (path, O_RDONLY) < 0)
149 if ((mode & W_OK) && open (path, O_WRONLY) < 0)
155 return stat (path, &st);
162 #define access fallback_access
166 /* Unix and internal stream I/O module */
168 static const int BUFFER_SIZE = 8192;
174 gfc_offset buffer_offset; /* File offset of the start of the buffer */
175 gfc_offset physical_offset; /* Current physical file offset */
176 gfc_offset logical_offset; /* Current logical file offset */
177 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
179 char *buffer; /* Pointer to the buffer. */
180 int fd; /* The POSIX file descriptor. */
182 int active; /* Length of valid bytes in the buffer */
184 int ndirty; /* Dirty bytes starting at buffer_offset */
186 int special_file; /* =1 if the fd refers to a special file */
188 /* Cached stat(2) values. */
195 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
196 * standard descriptors, returning a non-standard descriptor. If the
197 * user specifies that system errors should go to standard output,
198 * then closes standard output, we don't want the system errors to a
199 * file that has been given file descriptor 1 or 0. We want to send
200 * the error to the invalid descriptor. */
206 int input, output, error;
208 input = output = error = 0;
210 /* Unix allocates the lowest descriptors first, so a loop is not
211 required, but this order is. */
212 if (fd == STDIN_FILENO)
217 if (fd == STDOUT_FILENO)
222 if (fd == STDERR_FILENO)
229 close (STDIN_FILENO);
231 close (STDOUT_FILENO);
233 close (STDERR_FILENO);
240 /* If the stream corresponds to a preconnected unit, we flush the
241 corresponding C stream. This is bugware for mixed C-Fortran codes
242 where the C code doesn't flush I/O before returning. */
244 flush_if_preconnected (stream * s)
248 fd = ((unix_stream *) s)->fd;
249 if (fd == STDIN_FILENO)
251 else if (fd == STDOUT_FILENO)
253 else if (fd == STDERR_FILENO)
258 /* get_oserror()-- Get the most recent operating system error. For
259 * unix, this is errno. */
264 return strerror (errno);
268 /********************************************************************
269 Raw I/O functions (read, write, seek, tell, truncate, close).
271 These functions wrap the basic POSIX I/O syscalls. Any deviation in
272 semantics is a bug, except the following: write restarts in case
273 of being interrupted by a signal, and as the first argument the
274 functions take the unix_stream struct rather than an integer file
275 descriptor. Also, for POSIX read() and write() a nbyte argument larger
276 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
277 than size_t as for POSIX read/write.
278 *********************************************************************/
281 raw_flush (unix_stream * s __attribute__ ((unused)))
287 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
289 /* For read we can't do I/O in a loop like raw_write does, because
290 that will break applications that wait for interactive I/O. */
291 return read (s->fd, buf, nbyte);
295 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
297 ssize_t trans, bytes_left;
301 buf_st = (char *) buf;
303 /* We must write in a loop since some systems don't restart system
304 calls in case of a signal. */
305 while (bytes_left > 0)
307 trans = write (s->fd, buf_st, bytes_left);
319 return nbyte - bytes_left;
323 raw_seek (unix_stream * s, gfc_offset offset, int whence)
325 return lseek (s->fd, offset, whence);
329 raw_tell (unix_stream * s)
331 return lseek (s->fd, 0, SEEK_CUR);
335 raw_truncate (unix_stream * s, gfc_offset length)
346 h = (HANDLE) _get_osfhandle (s->fd);
347 if (h == INVALID_HANDLE_VALUE)
352 cur = lseek (s->fd, 0, SEEK_CUR);
355 if (lseek (s->fd, length, SEEK_SET) == -1)
357 if (!SetEndOfFile (h))
362 if (lseek (s->fd, cur, SEEK_SET) == -1)
366 lseek (s->fd, cur, SEEK_SET);
368 #elif defined HAVE_FTRUNCATE
369 return ftruncate (s->fd, length);
370 #elif defined HAVE_CHSIZE
371 return chsize (s->fd, length);
373 runtime_error ("required ftruncate or chsize support not present");
379 raw_close (unix_stream * s)
383 if (s->fd != STDOUT_FILENO
384 && s->fd != STDERR_FILENO
385 && s->fd != STDIN_FILENO)
386 retval = close (s->fd);
394 raw_init (unix_stream * s)
396 s->st.read = (void *) raw_read;
397 s->st.write = (void *) raw_write;
398 s->st.seek = (void *) raw_seek;
399 s->st.tell = (void *) raw_tell;
400 s->st.trunc = (void *) raw_truncate;
401 s->st.close = (void *) raw_close;
402 s->st.flush = (void *) raw_flush;
409 /*********************************************************************
410 Buffered I/O functions. These functions have the same semantics as the
411 raw I/O functions above, except that they are buffered in order to
412 improve performance. The buffer must be flushed when switching from
413 reading to writing and vice versa.
414 *********************************************************************/
417 buf_flush (unix_stream * s)
421 /* Flushing in read mode means discarding read bytes. */
427 if (s->file_length != -1 && s->physical_offset != s->buffer_offset
428 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
431 writelen = raw_write (s, s->buffer, s->ndirty);
433 s->physical_offset = s->buffer_offset + writelen;
435 /* Don't increment file_length if the file is non-seekable. */
436 if (s->file_length != -1 && s->physical_offset > s->file_length)
437 s->file_length = s->physical_offset;
439 s->ndirty -= writelen;
451 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
454 s->buffer_offset = s->logical_offset;
456 /* Is the data we want in the buffer? */
457 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
458 && s->buffer_offset <= s->logical_offset)
459 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
462 /* First copy the active bytes if applicable, then read the rest
463 either directly or filling the buffer. */
466 ssize_t to_read, did_read;
467 gfc_offset new_logical;
470 if (s->logical_offset >= s->buffer_offset
471 && s->buffer_offset + s->active >= s->logical_offset)
473 nread = s->active - (s->logical_offset - s->buffer_offset);
474 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
478 /* At this point we consider all bytes in the buffer discarded. */
479 to_read = nbyte - nread;
480 new_logical = s->logical_offset + nread;
481 if (s->file_length != -1 && s->physical_offset != new_logical
482 && lseek (s->fd, new_logical, SEEK_SET) < 0)
484 s->buffer_offset = s->physical_offset = new_logical;
485 if (to_read <= BUFFER_SIZE/2)
487 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
488 s->physical_offset += did_read;
489 s->active = did_read;
490 did_read = (did_read > to_read) ? to_read : did_read;
491 memcpy (p, s->buffer, did_read);
495 did_read = raw_read (s, p, to_read);
496 s->physical_offset += did_read;
499 nbyte = did_read + nread;
501 s->logical_offset += nbyte;
506 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
509 s->buffer_offset = s->logical_offset;
511 /* Does the data fit into the buffer? As a special case, if the
512 buffer is empty and the request is bigger than BUFFER_SIZE/2,
513 write directly. This avoids the case where the buffer would have
514 to be flushed at every write. */
515 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
516 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
517 && s->buffer_offset <= s->logical_offset
518 && s->buffer_offset + s->ndirty >= s->logical_offset)
520 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
521 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
527 /* Flush, and either fill the buffer with the new data, or if
528 the request is bigger than the buffer size, write directly
529 bypassing the buffer. */
531 if (nbyte <= BUFFER_SIZE/2)
533 memcpy (s->buffer, buf, nbyte);
534 s->buffer_offset = s->logical_offset;
539 if (s->file_length != -1 && s->physical_offset != s->logical_offset)
541 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
543 s->physical_offset = s->logical_offset;
546 nbyte = raw_write (s, buf, nbyte);
547 s->physical_offset += nbyte;
550 s->logical_offset += nbyte;
551 /* Don't increment file_length if the file is non-seekable. */
552 if (s->file_length != -1 && s->logical_offset > s->file_length)
553 s->file_length = s->logical_offset;
558 buf_seek (unix_stream * s, gfc_offset offset, int whence)
565 offset += s->logical_offset;
568 offset += s->file_length;
578 s->logical_offset = offset;
583 buf_tell (unix_stream * s)
585 return s->logical_offset;
589 buf_truncate (unix_stream * s, gfc_offset length)
593 if (buf_flush (s) != 0)
595 r = raw_truncate (s, length);
597 s->file_length = length;
602 buf_close (unix_stream * s)
604 if (buf_flush (s) != 0)
607 return raw_close (s);
611 buf_init (unix_stream * s)
613 s->st.read = (void *) buf_read;
614 s->st.write = (void *) buf_write;
615 s->st.seek = (void *) buf_seek;
616 s->st.tell = (void *) buf_tell;
617 s->st.trunc = (void *) buf_truncate;
618 s->st.close = (void *) buf_close;
619 s->st.flush = (void *) buf_flush;
621 s->buffer = get_mem (BUFFER_SIZE);
626 /*********************************************************************
627 memory stream functions - These are used for internal files
629 The idea here is that a single stream structure is created and all
630 requests must be satisfied from it. The location and size of the
631 buffer is the character variable supplied to the READ or WRITE
634 *********************************************************************/
637 mem_alloc_r (stream * strm, int * len)
639 unix_stream * s = (unix_stream *) strm;
641 gfc_offset where = s->logical_offset;
643 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
646 n = s->buffer_offset + s->active - where;
650 s->logical_offset = where + *len;
652 return s->buffer + (where - s->buffer_offset);
657 mem_alloc_r4 (stream * strm, int * len)
659 unix_stream * s = (unix_stream *) strm;
661 gfc_offset where = s->logical_offset;
663 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
666 n = s->buffer_offset + s->active - where;
670 s->logical_offset = where + *len;
672 return s->buffer + (where - s->buffer_offset) * 4;
677 mem_alloc_w (stream * strm, int * len)
679 unix_stream * s = (unix_stream *) strm;
681 gfc_offset where = s->logical_offset;
685 if (where < s->buffer_offset)
688 if (m > s->file_length)
691 s->logical_offset = m;
693 return s->buffer + (where - s->buffer_offset);
698 mem_alloc_w4 (stream * strm, int * len)
700 unix_stream * s = (unix_stream *) strm;
702 gfc_offset where = s->logical_offset;
703 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
707 if (where < s->buffer_offset)
710 if (m > s->file_length)
713 s->logical_offset = m;
714 return &result[where - s->buffer_offset];
718 /* Stream read function for character(kine=1) internal units. */
721 mem_read (stream * s, void * buf, ssize_t nbytes)
726 p = mem_alloc_r (s, &nb);
737 /* Stream read function for chracter(kind=4) internal units. */
740 mem_read4 (stream * s, void * buf, ssize_t nbytes)
745 p = mem_alloc_r (s, &nb);
756 /* Stream write function for character(kind=1) internal units. */
759 mem_write (stream * s, const void * buf, ssize_t nbytes)
764 p = mem_alloc_w (s, &nb);
775 /* Stream write function for character(kind=4) internal units. */
778 mem_write4 (stream * s, const void * buf, ssize_t nwords)
783 p = mem_alloc_w4 (s, &nw);
787 *p++ = (gfc_char4_t) *((char *) buf);
796 mem_seek (stream * strm, gfc_offset offset, int whence)
798 unix_stream * s = (unix_stream *) strm;
804 offset += s->logical_offset;
807 offset += s->file_length;
813 /* Note that for internal array I/O it's actually possible to have a
814 negative offset, so don't check for that. */
815 if (offset > s->file_length)
821 s->logical_offset = offset;
823 /* Returning < 0 is the error indicator for sseek(), so return 0 if
824 offset is negative. Thus if the return value is 0, the caller
825 has to use stell() to get the real value of logical_offset. */
833 mem_tell (stream * s)
835 return ((unix_stream *)s)->logical_offset;
840 mem_truncate (unix_stream * s __attribute__ ((unused)),
841 gfc_offset length __attribute__ ((unused)))
848 mem_flush (unix_stream * s __attribute__ ((unused)))
855 mem_close (unix_stream * s)
864 /*********************************************************************
865 Public functions -- A reimplementation of this module needs to
866 define functional equivalents of the following.
867 *********************************************************************/
869 /* open_internal()-- Returns a stream structure from a character(kind=1)
873 open_internal (char *base, int length, gfc_offset offset)
877 s = get_mem (sizeof (unix_stream));
878 memset (s, '\0', sizeof (unix_stream));
881 s->buffer_offset = offset;
883 s->logical_offset = 0;
884 s->active = s->file_length = length;
886 s->st.close = (void *) mem_close;
887 s->st.seek = (void *) mem_seek;
888 s->st.tell = (void *) mem_tell;
889 s->st.trunc = (void *) mem_truncate;
890 s->st.read = (void *) mem_read;
891 s->st.write = (void *) mem_write;
892 s->st.flush = (void *) mem_flush;
897 /* open_internal4()-- Returns a stream structure from a character(kind=4)
901 open_internal4 (char *base, int length, gfc_offset offset)
905 s = get_mem (sizeof (unix_stream));
906 memset (s, '\0', sizeof (unix_stream));
909 s->buffer_offset = offset;
911 s->logical_offset = 0;
912 s->active = s->file_length = length;
914 s->st.close = (void *) mem_close;
915 s->st.seek = (void *) mem_seek;
916 s->st.tell = (void *) mem_tell;
917 s->st.trunc = (void *) mem_truncate;
918 s->st.read = (void *) mem_read4;
919 s->st.write = (void *) mem_write4;
920 s->st.flush = (void *) mem_flush;
926 /* fd_to_stream()-- Given an open file descriptor, build a stream
930 fd_to_stream (int fd)
935 s = get_mem (sizeof (unix_stream));
936 memset (s, '\0', sizeof (unix_stream));
939 s->buffer_offset = 0;
940 s->physical_offset = 0;
941 s->logical_offset = 0;
943 /* Get the current length of the file. */
945 fstat (fd, &statbuf);
947 s->st_dev = statbuf.st_dev;
948 s->st_ino = statbuf.st_ino;
949 s->special_file = !S_ISREG (statbuf.st_mode);
951 if (S_ISREG (statbuf.st_mode))
952 s->file_length = statbuf.st_size;
953 else if (S_ISBLK (statbuf.st_mode))
955 /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)? */
956 gfc_offset cur = lseek (fd, 0, SEEK_CUR);
957 s->file_length = lseek (fd, 0, SEEK_END);
958 lseek (fd, cur, SEEK_SET);
963 if (!(S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
964 || options.all_unbuffered
965 ||(options.unbuffered_preconnected &&
966 (s->fd == STDIN_FILENO
967 || s->fd == STDOUT_FILENO
968 || s->fd == STDERR_FILENO))
978 /* Given the Fortran unit number, convert it to a C file descriptor. */
981 unit_to_fd (int unit)
986 us = find_unit (unit);
990 fd = ((unix_stream *) us->s)->fd;
996 /* unpack_filename()-- Given a fortran string and a pointer to a
997 * buffer that is PATH_MAX characters, convert the fortran string to a
998 * C string in the buffer. Returns nonzero if this is not possible. */
1001 unpack_filename (char *cstring, const char *fstring, int len)
1003 if (fstring == NULL)
1005 len = fstrlen (fstring, len);
1006 if (len >= PATH_MAX)
1009 memmove (cstring, fstring, len);
1010 cstring[len] = '\0';
1016 /* tempfile()-- Generate a temporary filename for a scratch file and
1017 * open it. mkstemp() opens the file for reading and writing, but the
1018 * library mode prevents anything that is not allowed. The descriptor
1019 * is returned, which is -1 on error. The template is pointed to by
1020 * opp->file, which is copied into the unit structure
1021 * and freed later. */
1024 tempfile (st_parameter_open *opp)
1026 const char *tempdir;
1028 const char *slash = "/";
1031 tempdir = getenv ("GFORTRAN_TMPDIR");
1033 if (tempdir == NULL)
1035 char buffer[MAX_PATH + 1];
1037 ret = GetTempPath (MAX_PATH, buffer);
1038 /* If we are not able to get a temp-directory, we use
1039 current directory. */
1040 if (ret > MAX_PATH || !ret)
1044 tempdir = strdup (buffer);
1047 if (tempdir == NULL)
1048 tempdir = getenv ("TMP");
1049 if (tempdir == NULL)
1050 tempdir = getenv ("TEMP");
1051 if (tempdir == NULL)
1052 tempdir = DEFAULT_TEMPDIR;
1054 /* Check for special case that tempdir contains slash
1055 or backslash at end. */
1056 if (*tempdir == 0 || tempdir[strlen (tempdir) - 1] == '/'
1058 || tempdir[strlen (tempdir) - 1] == '\\'
1063 template = get_mem (strlen (tempdir) + 20);
1066 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
1068 fd = mkstemp (template);
1070 #else /* HAVE_MKSTEMP */
1074 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
1075 if (!mktemp (template))
1077 #if defined(HAVE_CRLF) && defined(O_BINARY)
1078 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1079 S_IREAD | S_IWRITE);
1081 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1084 while (fd == -1 && errno == EEXIST);
1085 #endif /* HAVE_MKSTEMP */
1091 opp->file = template;
1092 opp->file_len = strlen (template); /* Don't include trailing nul */
1099 /* regular_file()-- Open a regular file.
1100 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1101 * unless an error occurs.
1102 * Returns the descriptor, which is less than zero on error. */
1105 regular_file (st_parameter_open *opp, unit_flags *flags)
1107 char path[PATH_MAX + 1];
1113 if (unpack_filename (path, opp->file, opp->file_len))
1115 errno = ENOENT; /* Fake an OS error */
1120 if (opp->file_len == 7)
1122 if (strncmp (path, "CONOUT$", 7) == 0
1123 || strncmp (path, "CONERR$", 7) == 0)
1125 fd = open ("/dev/conout", O_WRONLY);
1126 flags->action = ACTION_WRITE;
1131 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1133 fd = open ("/dev/conin", O_RDONLY);
1134 flags->action = ACTION_READ;
1141 if (opp->file_len == 7)
1143 if (strncmp (path, "CONOUT$", 7) == 0
1144 || strncmp (path, "CONERR$", 7) == 0)
1146 fd = open ("CONOUT$", O_WRONLY);
1147 flags->action = ACTION_WRITE;
1152 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1154 fd = open ("CONIN$", O_RDONLY);
1155 flags->action = ACTION_READ;
1162 switch (flags->action)
1172 case ACTION_READWRITE:
1173 case ACTION_UNSPECIFIED:
1178 internal_error (&opp->common, "regular_file(): Bad action");
1181 switch (flags->status)
1184 crflag = O_CREAT | O_EXCL;
1187 case STATUS_OLD: /* open will fail if the file does not exist*/
1191 case STATUS_UNKNOWN:
1192 case STATUS_SCRATCH:
1196 case STATUS_REPLACE:
1197 crflag = O_CREAT | O_TRUNC;
1201 internal_error (&opp->common, "regular_file(): Bad status");
1204 /* rwflag |= O_LARGEFILE; */
1206 #if defined(HAVE_CRLF) && defined(O_BINARY)
1210 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1211 fd = open (path, rwflag | crflag, mode);
1212 if (flags->action != ACTION_UNSPECIFIED)
1217 flags->action = ACTION_READWRITE;
1220 if (errno != EACCES && errno != EROFS)
1223 /* retry for read-only access */
1225 fd = open (path, rwflag | crflag, mode);
1228 flags->action = ACTION_READ;
1229 return fd; /* success */
1232 if (errno != EACCES)
1233 return fd; /* failure */
1235 /* retry for write-only access */
1237 fd = open (path, rwflag | crflag, mode);
1240 flags->action = ACTION_WRITE;
1241 return fd; /* success */
1243 return fd; /* failure */
1247 /* open_external()-- Open an external file, unix specific version.
1248 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1249 * Returns NULL on operating system error. */
1252 open_external (st_parameter_open *opp, unit_flags *flags)
1256 if (flags->status == STATUS_SCRATCH)
1258 fd = tempfile (opp);
1259 if (flags->action == ACTION_UNSPECIFIED)
1260 flags->action = ACTION_READWRITE;
1262 #if HAVE_UNLINK_OPEN_FILE
1263 /* We can unlink scratch files now and it will go away when closed. */
1270 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1272 fd = regular_file (opp, flags);
1279 return fd_to_stream (fd);
1283 /* input_stream()-- Return a stream pointer to the default input stream.
1284 * Called on initialization. */
1289 return fd_to_stream (STDIN_FILENO);
1293 /* output_stream()-- Return a stream pointer to the default output stream.
1294 * Called on initialization. */
1297 output_stream (void)
1301 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1302 setmode (STDOUT_FILENO, O_BINARY);
1305 s = fd_to_stream (STDOUT_FILENO);
1310 /* error_stream()-- Return a stream pointer to the default error stream.
1311 * Called on initialization. */
1318 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1319 setmode (STDERR_FILENO, O_BINARY);
1322 s = fd_to_stream (STDERR_FILENO);
1327 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1328 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1329 is big enough to completely fill a 80x25 terminal, so it shuld be
1330 OK. We use a direct write() because it is simpler and least likely
1331 to be clobbered by memory corruption. Writing an error message
1332 longer than that is an error. */
1334 #define ST_VPRINTF_SIZE 2048
1337 st_vprintf (const char *format, va_list ap)
1339 static char buffer[ST_VPRINTF_SIZE];
1343 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1344 #ifdef HAVE_VSNPRINTF
1345 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1347 written = vsprintf(buffer, format, ap);
1349 if (written >= ST_VPRINTF_SIZE-1)
1351 /* The error message was longer than our buffer. Ouch. Because
1352 we may have messed up things badly, report the error and
1354 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1355 write (fd, buffer, ST_VPRINTF_SIZE-1);
1356 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1358 #undef ERROR_MESSAGE
1363 written = write (fd, buffer, written);
1367 /* st_printf()-- printf() function for error output. This just calls
1368 st_vprintf() to do the actual work. */
1371 st_printf (const char *format, ...)
1375 va_start (ap, format);
1376 written = st_vprintf(format, ap);
1382 /* compare_file_filename()-- Given an open stream and a fortran string
1383 * that is a filename, figure out if the file is the same as the
1387 compare_file_filename (gfc_unit *u, const char *name, int len)
1389 char path[PATH_MAX + 1];
1391 #ifdef HAVE_WORKING_STAT
1399 if (unpack_filename (path, name, len))
1400 return 0; /* Can't be the same */
1402 /* If the filename doesn't exist, then there is no match with the
1405 if (stat (path, &st) < 0)
1408 #ifdef HAVE_WORKING_STAT
1409 s = (unix_stream *) (u->s);
1410 return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1414 /* We try to match files by a unique ID. On some filesystems (network
1415 fs and FAT), we can't generate this unique ID, and will simply compare
1417 id1 = id_from_path (path);
1418 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1420 return (id1 == id2);
1423 if (len != u->file_len)
1425 return (memcmp(path, u->file, len) == 0);
1430 #ifdef HAVE_WORKING_STAT
1431 # define FIND_FILE0_DECL gfstat_t *st
1432 # define FIND_FILE0_ARGS st
1434 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1435 # define FIND_FILE0_ARGS id, file, file_len
1438 /* find_file0()-- Recursive work function for find_file() */
1441 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1444 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1451 #ifdef HAVE_WORKING_STAT
1454 unix_stream *s = (unix_stream *) (u->s);
1455 if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1460 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1467 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1471 v = find_file0 (u->left, FIND_FILE0_ARGS);
1475 v = find_file0 (u->right, FIND_FILE0_ARGS);
1483 /* find_file()-- Take the current filename and see if there is a unit
1484 * that has the file already open. Returns a pointer to the unit if so. */
1487 find_file (const char *file, gfc_charlen_type file_len)
1489 char path[PATH_MAX + 1];
1492 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1496 if (unpack_filename (path, file, file_len))
1499 if (stat (path, &st[0]) < 0)
1502 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1503 id = id_from_path (path);
1506 __gthread_mutex_lock (&unit_lock);
1508 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1512 if (! __gthread_mutex_trylock (&u->lock))
1514 /* assert (u->closed == 0); */
1515 __gthread_mutex_unlock (&unit_lock);
1519 inc_waiting_locked (u);
1521 __gthread_mutex_unlock (&unit_lock);
1524 __gthread_mutex_lock (&u->lock);
1527 __gthread_mutex_lock (&unit_lock);
1528 __gthread_mutex_unlock (&u->lock);
1529 if (predec_waiting_locked (u) == 0)
1534 dec_waiting_unlocked (u);
1540 flush_all_units_1 (gfc_unit *u, int min_unit)
1544 if (u->unit_number > min_unit)
1546 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1550 if (u->unit_number >= min_unit)
1552 if (__gthread_mutex_trylock (&u->lock))
1556 __gthread_mutex_unlock (&u->lock);
1564 flush_all_units (void)
1569 __gthread_mutex_lock (&unit_lock);
1572 u = flush_all_units_1 (unit_root, min_unit);
1574 inc_waiting_locked (u);
1575 __gthread_mutex_unlock (&unit_lock);
1579 __gthread_mutex_lock (&u->lock);
1581 min_unit = u->unit_number + 1;
1586 __gthread_mutex_lock (&unit_lock);
1587 __gthread_mutex_unlock (&u->lock);
1588 (void) predec_waiting_locked (u);
1592 __gthread_mutex_lock (&unit_lock);
1593 __gthread_mutex_unlock (&u->lock);
1594 if (predec_waiting_locked (u) == 0)
1602 /* delete_file()-- Given a unit structure, delete the file associated
1603 * with the unit. Returns nonzero if something went wrong. */
1606 delete_file (gfc_unit * u)
1608 char path[PATH_MAX + 1];
1610 if (unpack_filename (path, u->file, u->file_len))
1611 { /* Shouldn't be possible */
1616 return unlink (path);
1620 /* file_exists()-- Returns nonzero if the current filename exists on
1624 file_exists (const char *file, gfc_charlen_type file_len)
1626 char path[PATH_MAX + 1];
1628 if (unpack_filename (path, file, file_len))
1631 return !(access (path, F_OK));
1635 /* file_size()-- Returns the size of the file. */
1638 file_size (const char *file, gfc_charlen_type file_len)
1640 char path[PATH_MAX + 1];
1643 if (unpack_filename (path, file, file_len))
1646 if (stat (path, &statbuf) < 0)
1649 return (GFC_IO_INT) statbuf.st_size;
1652 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1654 /* inquire_sequential()-- Given a fortran string, determine if the
1655 * file is suitable for sequential access. Returns a C-style
1659 inquire_sequential (const char *string, int len)
1661 char path[PATH_MAX + 1];
1664 if (string == NULL ||
1665 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1668 if (S_ISREG (statbuf.st_mode) ||
1669 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1672 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1679 /* inquire_direct()-- Given a fortran string, determine if the file is
1680 * suitable for direct access. Returns a C-style string. */
1683 inquire_direct (const char *string, int len)
1685 char path[PATH_MAX + 1];
1688 if (string == NULL ||
1689 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1692 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1695 if (S_ISDIR (statbuf.st_mode) ||
1696 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1703 /* inquire_formatted()-- Given a fortran string, determine if the file
1704 * is suitable for formatted form. Returns a C-style string. */
1707 inquire_formatted (const char *string, int len)
1709 char path[PATH_MAX + 1];
1712 if (string == NULL ||
1713 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1716 if (S_ISREG (statbuf.st_mode) ||
1717 S_ISBLK (statbuf.st_mode) ||
1718 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1721 if (S_ISDIR (statbuf.st_mode))
1728 /* inquire_unformatted()-- Given a fortran string, determine if the file
1729 * is suitable for unformatted form. Returns a C-style string. */
1732 inquire_unformatted (const char *string, int len)
1734 return inquire_formatted (string, len);
1738 /* inquire_access()-- Given a fortran string, determine if the file is
1739 * suitable for access. */
1742 inquire_access (const char *string, int len, int mode)
1744 char path[PATH_MAX + 1];
1746 if (string == NULL || unpack_filename (path, string, len) ||
1747 access (path, mode) < 0)
1754 /* inquire_read()-- Given a fortran string, determine if the file is
1755 * suitable for READ access. */
1758 inquire_read (const char *string, int len)
1760 return inquire_access (string, len, R_OK);
1764 /* inquire_write()-- Given a fortran string, determine if the file is
1765 * suitable for READ access. */
1768 inquire_write (const char *string, int len)
1770 return inquire_access (string, len, W_OK);
1774 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1775 * suitable for read and write access. */
1778 inquire_readwrite (const char *string, int len)
1780 return inquire_access (string, len, R_OK | W_OK);
1784 /* file_length()-- Return the file length in bytes, -1 if unknown */
1787 file_length (stream * s)
1789 gfc_offset curr, end;
1790 if (!is_seekable (s))
1795 end = sseek (s, 0, SEEK_END);
1796 sseek (s, curr, SEEK_SET);
1801 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1805 is_seekable (stream *s)
1807 /* By convention, if file_length == -1, the file is not
1809 return ((unix_stream *) s)->file_length!=-1;
1813 /* is_special()-- Return nonzero if the stream is not a regular file. */
1816 is_special (stream *s)
1818 return ((unix_stream *) s)->special_file;
1823 stream_isatty (stream *s)
1825 return isatty (((unix_stream *) s)->fd);
1830 stream_ttyname (stream *s)
1832 return ttyname (((unix_stream *) s)->fd);
1835 stream_ttyname (stream *s __attribute__ ((unused)))
1843 /* How files are stored: This is an operating-system specific issue,
1844 and therefore belongs here. There are three cases to consider.
1847 Records are written as block of bytes corresponding to the record
1848 length of the file. This goes for both formatted and unformatted
1849 records. Positioning is done explicitly for each data transfer,
1850 so positioning is not much of an issue.
1852 Sequential Formatted:
1853 Records are separated by newline characters. The newline character
1854 is prohibited from appearing in a string. If it does, this will be
1855 messed up on the next read. End of file is also the end of a record.
1857 Sequential Unformatted:
1858 In this case, we are merely copying bytes to and from main storage,
1859 yet we need to keep track of varying record lengths. We adopt
1860 the solution used by f2c. Each record contains a pair of length
1863 Length of record n in bytes
1865 Length of record n in bytes
1867 Length of record n+1 in bytes
1869 Length of record n+1 in bytes
1871 The length is stored at the end of a record to allow backspacing to the
1872 previous record. Between data transfer statements, the file pointer
1873 is left pointing to the first length of the current record.
1875 ENDFILE records are never explicitly stored.