1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 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. */
45 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
47 #define WIN32_LEAN_AND_MEAN
51 id_from_handle (HANDLE hFile)
53 BY_HANDLE_FILE_INFORMATION FileInformation;
55 if (hFile == INVALID_HANDLE_VALUE)
58 memset (&FileInformation, 0, sizeof(FileInformation));
59 if (!GetFileInformationByHandle (hFile, &FileInformation))
62 return ((uint64_t) FileInformation.nFileIndexLow)
63 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
68 id_from_path (const char *path)
73 if (!path || !*path || access (path, F_OK))
76 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
77 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
79 res = id_from_handle (hFile);
86 id_from_fd (const int fd)
88 return id_from_handle ((HANDLE) _get_osfhandle (fd));
105 /* These flags aren't defined on all targets (mingw32), so provide them
124 /* Unix and internal stream I/O module */
126 static const int BUFFER_SIZE = 8192;
132 gfc_offset buffer_offset; /* File offset of the start of the buffer */
133 gfc_offset physical_offset; /* Current physical file offset */
134 gfc_offset logical_offset; /* Current logical file offset */
135 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
137 char *buffer; /* Pointer to the buffer. */
138 int fd; /* The POSIX file descriptor. */
140 int active; /* Length of valid bytes in the buffer */
143 int ndirty; /* Dirty bytes starting at buffer_offset */
145 int special_file; /* =1 if the fd refers to a special file */
150 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
151 * standard descriptors, returning a non-standard descriptor. If the
152 * user specifies that system errors should go to standard output,
153 * then closes standard output, we don't want the system errors to a
154 * file that has been given file descriptor 1 or 0. We want to send
155 * the error to the invalid descriptor. */
161 int input, output, error;
163 input = output = error = 0;
165 /* Unix allocates the lowest descriptors first, so a loop is not
166 required, but this order is. */
167 if (fd == STDIN_FILENO)
172 if (fd == STDOUT_FILENO)
177 if (fd == STDERR_FILENO)
184 close (STDIN_FILENO);
186 close (STDOUT_FILENO);
188 close (STDERR_FILENO);
195 /* If the stream corresponds to a preconnected unit, we flush the
196 corresponding C stream. This is bugware for mixed C-Fortran codes
197 where the C code doesn't flush I/O before returning. */
199 flush_if_preconnected (stream * s)
203 fd = ((unix_stream *) s)->fd;
204 if (fd == STDIN_FILENO)
206 else if (fd == STDOUT_FILENO)
208 else if (fd == STDERR_FILENO)
213 /* get_oserror()-- Get the most recent operating system error. For
214 * unix, this is errno. */
219 return strerror (errno);
223 /********************************************************************
224 Raw I/O functions (read, write, seek, tell, truncate, close).
226 These functions wrap the basic POSIX I/O syscalls. Any deviation in
227 semantics is a bug, except the following: write restarts in case
228 of being interrupted by a signal, and as the first argument the
229 functions take the unix_stream struct rather than an integer file
230 descriptor. Also, for POSIX read() and write() a nbyte argument larger
231 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
232 than size_t as for POSIX read/write.
233 *********************************************************************/
236 raw_flush (unix_stream * s __attribute__ ((unused)))
242 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
244 /* For read we can't do I/O in a loop like raw_write does, because
245 that will break applications that wait for interactive I/O. */
246 return read (s->fd, buf, nbyte);
250 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
252 ssize_t trans, bytes_left;
256 buf_st = (char *) buf;
258 /* We must write in a loop since some systems don't restart system
259 calls in case of a signal. */
260 while (bytes_left > 0)
262 trans = write (s->fd, buf_st, bytes_left);
274 return nbyte - bytes_left;
278 raw_seek (unix_stream * s, off_t offset, int whence)
280 return lseek (s->fd, offset, whence);
284 raw_tell (unix_stream * s)
286 return lseek (s->fd, 0, SEEK_CUR);
290 raw_truncate (unix_stream * s, off_t length)
292 #ifdef HAVE_FTRUNCATE
293 return ftruncate (s->fd, length);
294 #elif defined HAVE_CHSIZE
295 return chsize (s->fd, length);
297 runtime_error ("required ftruncate or chsize support not present");
303 raw_close (unix_stream * s)
307 if (s->fd != STDOUT_FILENO
308 && s->fd != STDERR_FILENO
309 && s->fd != STDIN_FILENO)
310 retval = close (s->fd);
318 raw_init (unix_stream * s)
320 s->st.read = (void *) raw_read;
321 s->st.write = (void *) raw_write;
322 s->st.seek = (void *) raw_seek;
323 s->st.tell = (void *) raw_tell;
324 s->st.trunc = (void *) raw_truncate;
325 s->st.close = (void *) raw_close;
326 s->st.flush = (void *) raw_flush;
333 /*********************************************************************
334 Buffered I/O functions. These functions have the same semantics as the
335 raw I/O functions above, except that they are buffered in order to
336 improve performance. The buffer must be flushed when switching from
337 reading to writing and vice versa.
338 *********************************************************************/
341 buf_flush (unix_stream * s)
345 /* Flushing in read mode means discarding read bytes. */
351 if (s->file_length != -1 && s->physical_offset != s->buffer_offset
352 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
355 writelen = raw_write (s, s->buffer, s->ndirty);
357 s->physical_offset = s->buffer_offset + writelen;
359 /* Don't increment file_length if the file is non-seekable. */
360 if (s->file_length != -1 && s->physical_offset > s->file_length)
361 s->file_length = s->physical_offset;
363 s->ndirty -= writelen;
371 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
374 s->buffer_offset = s->logical_offset;
376 /* Is the data we want in the buffer? */
377 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
378 && s->buffer_offset <= s->logical_offset)
379 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
382 /* First copy the active bytes if applicable, then read the rest
383 either directly or filling the buffer. */
386 ssize_t to_read, did_read;
387 gfc_offset new_logical;
390 if (s->logical_offset >= s->buffer_offset
391 && s->buffer_offset + s->active >= s->logical_offset)
393 nread = s->active - (s->logical_offset - s->buffer_offset);
394 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
398 /* At this point we consider all bytes in the buffer discarded. */
399 to_read = nbyte - nread;
400 new_logical = s->logical_offset + nread;
401 if (s->file_length != -1 && s->physical_offset != new_logical
402 && lseek (s->fd, new_logical, SEEK_SET) < 0)
404 s->buffer_offset = s->physical_offset = new_logical;
405 if (to_read <= BUFFER_SIZE/2)
407 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
408 s->physical_offset += did_read;
409 s->active = did_read;
410 did_read = (did_read > to_read) ? to_read : did_read;
411 memcpy (p, s->buffer, did_read);
415 did_read = raw_read (s, p, to_read);
416 s->physical_offset += did_read;
419 nbyte = did_read + nread;
421 s->logical_offset += nbyte;
426 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
429 s->buffer_offset = s->logical_offset;
431 /* Does the data fit into the buffer? As a special case, if the
432 buffer is empty and the request is bigger than BUFFER_SIZE/2,
433 write directly. This avoids the case where the buffer would have
434 to be flushed at every write. */
435 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
436 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
437 && s->buffer_offset <= s->logical_offset
438 && s->buffer_offset + s->ndirty >= s->logical_offset)
440 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
441 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
447 /* Flush, and either fill the buffer with the new data, or if
448 the request is bigger than the buffer size, write directly
449 bypassing the buffer. */
451 if (nbyte <= BUFFER_SIZE/2)
453 memcpy (s->buffer, buf, nbyte);
454 s->buffer_offset = s->logical_offset;
459 if (s->file_length != -1 && s->physical_offset != s->logical_offset
460 && lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
462 nbyte = raw_write (s, buf, nbyte);
463 s->physical_offset += nbyte;
466 s->logical_offset += nbyte;
467 /* Don't increment file_length if the file is non-seekable. */
468 if (s->file_length != -1 && s->logical_offset > s->file_length)
469 s->file_length = s->logical_offset;
474 buf_seek (unix_stream * s, off_t offset, int whence)
481 offset += s->logical_offset;
484 offset += s->file_length;
494 s->logical_offset = offset;
499 buf_tell (unix_stream * s)
501 return s->logical_offset;
505 buf_truncate (unix_stream * s, off_t length)
509 if (buf_flush (s) != 0)
511 r = raw_truncate (s, length);
513 s->file_length = length;
518 buf_close (unix_stream * s)
520 if (buf_flush (s) != 0)
522 free_mem (s->buffer);
523 return raw_close (s);
527 buf_init (unix_stream * s)
529 s->st.read = (void *) buf_read;
530 s->st.write = (void *) buf_write;
531 s->st.seek = (void *) buf_seek;
532 s->st.tell = (void *) buf_tell;
533 s->st.trunc = (void *) buf_truncate;
534 s->st.close = (void *) buf_close;
535 s->st.flush = (void *) buf_flush;
537 s->buffer = get_mem (BUFFER_SIZE);
542 /*********************************************************************
543 memory stream functions - These are used for internal files
545 The idea here is that a single stream structure is created and all
546 requests must be satisfied from it. The location and size of the
547 buffer is the character variable supplied to the READ or WRITE
550 *********************************************************************/
554 mem_alloc_r (stream * strm, int * len)
556 unix_stream * s = (unix_stream *) strm;
558 gfc_offset where = s->logical_offset;
560 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
563 n = s->buffer_offset + s->active - where;
567 s->logical_offset = where + *len;
569 return s->buffer + (where - s->buffer_offset);
574 mem_alloc_w (stream * strm, int * len)
576 unix_stream * s = (unix_stream *) strm;
578 gfc_offset where = s->logical_offset;
582 if (where < s->buffer_offset)
585 if (m > s->file_length)
588 s->logical_offset = m;
590 return s->buffer + (where - s->buffer_offset);
594 /* Stream read function for internal units. */
597 mem_read (stream * s, void * buf, ssize_t nbytes)
602 p = mem_alloc_r (s, &nb);
613 /* Stream write function for internal units. This is not actually used
614 at the moment, as all internal IO is formatted and the formatted IO
615 routines use mem_alloc_w_at. */
618 mem_write (stream * s, const void * buf, ssize_t nbytes)
623 p = mem_alloc_w (s, &nb);
635 mem_seek (stream * strm, off_t offset, int whence)
637 unix_stream * s = (unix_stream *) strm;
643 offset += s->logical_offset;
646 offset += s->file_length;
652 /* Note that for internal array I/O it's actually possible to have a
653 negative offset, so don't check for that. */
654 if (offset > s->file_length)
660 s->logical_offset = offset;
662 /* Returning < 0 is the error indicator for sseek(), so return 0 if
663 offset is negative. Thus if the return value is 0, the caller
664 has to use stell() to get the real value of logical_offset. */
672 mem_tell (stream * s)
674 return ((unix_stream *)s)->logical_offset;
679 mem_truncate (unix_stream * s __attribute__ ((unused)),
680 off_t length __attribute__ ((unused)))
687 mem_flush (unix_stream * s __attribute__ ((unused)))
694 mem_close (unix_stream * s)
703 /*********************************************************************
704 Public functions -- A reimplementation of this module needs to
705 define functional equivalents of the following.
706 *********************************************************************/
708 /* empty_internal_buffer()-- Zero the buffer of Internal file */
711 empty_internal_buffer(stream *strm)
713 unix_stream * s = (unix_stream *) strm;
714 memset(s->buffer, ' ', s->file_length);
717 /* open_internal()-- Returns a stream structure from an internal file */
720 open_internal (char *base, int length, gfc_offset offset)
724 s = get_mem (sizeof (unix_stream));
725 memset (s, '\0', sizeof (unix_stream));
728 s->buffer_offset = offset;
730 s->logical_offset = 0;
731 s->active = s->file_length = length;
733 s->st.close = (void *) mem_close;
734 s->st.seek = (void *) mem_seek;
735 s->st.tell = (void *) mem_tell;
736 s->st.trunc = (void *) mem_truncate;
737 s->st.read = (void *) mem_read;
738 s->st.write = (void *) mem_write;
739 s->st.flush = (void *) mem_flush;
745 /* fd_to_stream()-- Given an open file descriptor, build a stream
749 fd_to_stream (int fd, int prot)
754 s = get_mem (sizeof (unix_stream));
755 memset (s, '\0', sizeof (unix_stream));
758 s->buffer_offset = 0;
759 s->physical_offset = 0;
760 s->logical_offset = 0;
763 /* Get the current length of the file. */
765 fstat (fd, &statbuf);
767 if (lseek (fd, 0, SEEK_CUR) == (off_t) -1)
770 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
772 s->special_file = !S_ISREG (statbuf.st_mode);
774 if (isatty (s->fd) || options.all_unbuffered
775 ||(options.unbuffered_preconnected &&
776 (s->fd == STDIN_FILENO
777 || s->fd == STDOUT_FILENO
778 || s->fd == STDERR_FILENO)))
787 /* Given the Fortran unit number, convert it to a C file descriptor. */
790 unit_to_fd (int unit)
795 us = find_unit (unit);
799 fd = ((unix_stream *) us->s)->fd;
805 /* unpack_filename()-- Given a fortran string and a pointer to a
806 * buffer that is PATH_MAX characters, convert the fortran string to a
807 * C string in the buffer. Returns nonzero if this is not possible. */
810 unpack_filename (char *cstring, const char *fstring, int len)
812 len = fstrlen (fstring, len);
816 memmove (cstring, fstring, len);
823 /* tempfile()-- Generate a temporary filename for a scratch file and
824 * open it. mkstemp() opens the file for reading and writing, but the
825 * library mode prevents anything that is not allowed. The descriptor
826 * is returned, which is -1 on error. The template is pointed to by
827 * opp->file, which is copied into the unit structure
828 * and freed later. */
831 tempfile (st_parameter_open *opp)
837 tempdir = getenv ("GFORTRAN_TMPDIR");
839 tempdir = getenv ("TMP");
841 tempdir = getenv ("TEMP");
843 tempdir = DEFAULT_TEMPDIR;
845 template = get_mem (strlen (tempdir) + 20);
847 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
851 fd = mkstemp (template);
853 #else /* HAVE_MKSTEMP */
855 if (mktemp (template))
857 #if defined(HAVE_CRLF) && defined(O_BINARY)
858 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
861 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
863 while (!(fd == -1 && errno == EEXIST) && mktemp (template));
867 #endif /* HAVE_MKSTEMP */
873 opp->file = template;
874 opp->file_len = strlen (template); /* Don't include trailing nul */
881 /* regular_file()-- Open a regular file.
882 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
883 * unless an error occurs.
884 * Returns the descriptor, which is less than zero on error. */
887 regular_file (st_parameter_open *opp, unit_flags *flags)
889 char path[PATH_MAX + 1];
895 if (unpack_filename (path, opp->file, opp->file_len))
897 errno = ENOENT; /* Fake an OS error */
902 if (opp->file_len == 7)
904 if (strncmp (path, "CONOUT$", 7) == 0
905 || strncmp (path, "CONERR$", 7) == 0)
907 fd = open ("/dev/conout", O_WRONLY);
908 flags->action = ACTION_WRITE;
913 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
915 fd = open ("/dev/conin", O_RDONLY);
916 flags->action = ACTION_READ;
923 if (opp->file_len == 7)
925 if (strncmp (path, "CONOUT$", 7) == 0
926 || strncmp (path, "CONERR$", 7) == 0)
928 fd = open ("CONOUT$", O_WRONLY);
929 flags->action = ACTION_WRITE;
934 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
936 fd = open ("CONIN$", O_RDONLY);
937 flags->action = ACTION_READ;
944 switch (flags->action)
954 case ACTION_READWRITE:
955 case ACTION_UNSPECIFIED:
960 internal_error (&opp->common, "regular_file(): Bad action");
963 switch (flags->status)
966 crflag = O_CREAT | O_EXCL;
969 case STATUS_OLD: /* open will fail if the file does not exist*/
979 crflag = O_CREAT | O_TRUNC;
983 internal_error (&opp->common, "regular_file(): Bad status");
986 /* rwflag |= O_LARGEFILE; */
988 #if defined(HAVE_CRLF) && defined(O_BINARY)
992 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
993 fd = open (path, rwflag | crflag, mode);
994 if (flags->action != ACTION_UNSPECIFIED)
999 flags->action = ACTION_READWRITE;
1002 if (errno != EACCES && errno != EROFS)
1005 /* retry for read-only access */
1007 fd = open (path, rwflag | crflag, mode);
1010 flags->action = ACTION_READ;
1011 return fd; /* success */
1014 if (errno != EACCES)
1015 return fd; /* failure */
1017 /* retry for write-only access */
1019 fd = open (path, rwflag | crflag, mode);
1022 flags->action = ACTION_WRITE;
1023 return fd; /* success */
1025 return fd; /* failure */
1029 /* open_external()-- Open an external file, unix specific version.
1030 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1031 * Returns NULL on operating system error. */
1034 open_external (st_parameter_open *opp, unit_flags *flags)
1038 if (flags->status == STATUS_SCRATCH)
1040 fd = tempfile (opp);
1041 if (flags->action == ACTION_UNSPECIFIED)
1042 flags->action = ACTION_READWRITE;
1044 #if HAVE_UNLINK_OPEN_FILE
1045 /* We can unlink scratch files now and it will go away when closed. */
1052 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1054 fd = regular_file (opp, flags);
1061 switch (flags->action)
1071 case ACTION_READWRITE:
1072 prot = PROT_READ | PROT_WRITE;
1076 internal_error (&opp->common, "open_external(): Bad action");
1079 return fd_to_stream (fd, prot);
1083 /* input_stream()-- Return a stream pointer to the default input stream.
1084 * Called on initialization. */
1089 return fd_to_stream (STDIN_FILENO, PROT_READ);
1093 /* output_stream()-- Return a stream pointer to the default output stream.
1094 * Called on initialization. */
1097 output_stream (void)
1101 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1102 setmode (STDOUT_FILENO, O_BINARY);
1105 s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1110 /* error_stream()-- Return a stream pointer to the default error stream.
1111 * Called on initialization. */
1118 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1119 setmode (STDERR_FILENO, O_BINARY);
1122 s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1127 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1128 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1129 is big enough to completely fill a 80x25 terminal, so it shuld be
1130 OK. We use a direct write() because it is simpler and least likely
1131 to be clobbered by memory corruption. Writing an error message
1132 longer than that is an error. */
1134 #define ST_VPRINTF_SIZE 2048
1137 st_vprintf (const char *format, va_list ap)
1139 static char buffer[ST_VPRINTF_SIZE];
1143 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1144 #ifdef HAVE_VSNPRINTF
1145 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1147 written = vsprintf(buffer, format, ap);
1149 if (written >= ST_VPRINTF_SIZE-1)
1151 /* The error message was longer than our buffer. Ouch. Because
1152 we may have messed up things badly, report the error and
1154 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1155 write (fd, buffer, ST_VPRINTF_SIZE-1);
1156 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1158 #undef ERROR_MESSAGE
1163 written = write (fd, buffer, written);
1167 /* st_printf()-- printf() function for error output. This just calls
1168 st_vprintf() to do the actual work. */
1171 st_printf (const char *format, ...)
1175 va_start (ap, format);
1176 written = st_vprintf(format, ap);
1182 /* compare_file_filename()-- Given an open stream and a fortran string
1183 * that is a filename, figure out if the file is the same as the
1187 compare_file_filename (gfc_unit *u, const char *name, int len)
1189 char path[PATH_MAX + 1];
1191 #ifdef HAVE_WORKING_STAT
1199 if (unpack_filename (path, name, len))
1200 return 0; /* Can't be the same */
1202 /* If the filename doesn't exist, then there is no match with the
1205 if (stat (path, &st1) < 0)
1208 #ifdef HAVE_WORKING_STAT
1209 fstat (((unix_stream *) (u->s))->fd, &st2);
1210 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1214 /* We try to match files by a unique ID. On some filesystems (network
1215 fs and FAT), we can't generate this unique ID, and will simply compare
1217 id1 = id_from_path (path);
1218 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1220 return (id1 == id2);
1223 if (len != u->file_len)
1225 return (memcmp(path, u->file, len) == 0);
1230 #ifdef HAVE_WORKING_STAT
1231 # define FIND_FILE0_DECL struct stat *st
1232 # define FIND_FILE0_ARGS st
1234 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1235 # define FIND_FILE0_ARGS id, file, file_len
1238 /* find_file0()-- Recursive work function for find_file() */
1241 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1244 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1251 #ifdef HAVE_WORKING_STAT
1253 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1254 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1258 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1265 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1269 v = find_file0 (u->left, FIND_FILE0_ARGS);
1273 v = find_file0 (u->right, FIND_FILE0_ARGS);
1281 /* find_file()-- Take the current filename and see if there is a unit
1282 * that has the file already open. Returns a pointer to the unit if so. */
1285 find_file (const char *file, gfc_charlen_type file_len)
1287 char path[PATH_MAX + 1];
1290 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1294 if (unpack_filename (path, file, file_len))
1297 if (stat (path, &st[0]) < 0)
1300 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1301 id = id_from_path (path);
1304 __gthread_mutex_lock (&unit_lock);
1306 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1310 if (! __gthread_mutex_trylock (&u->lock))
1312 /* assert (u->closed == 0); */
1313 __gthread_mutex_unlock (&unit_lock);
1317 inc_waiting_locked (u);
1319 __gthread_mutex_unlock (&unit_lock);
1322 __gthread_mutex_lock (&u->lock);
1325 __gthread_mutex_lock (&unit_lock);
1326 __gthread_mutex_unlock (&u->lock);
1327 if (predec_waiting_locked (u) == 0)
1332 dec_waiting_unlocked (u);
1338 flush_all_units_1 (gfc_unit *u, int min_unit)
1342 if (u->unit_number > min_unit)
1344 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1348 if (u->unit_number >= min_unit)
1350 if (__gthread_mutex_trylock (&u->lock))
1354 __gthread_mutex_unlock (&u->lock);
1362 flush_all_units (void)
1367 __gthread_mutex_lock (&unit_lock);
1370 u = flush_all_units_1 (unit_root, min_unit);
1372 inc_waiting_locked (u);
1373 __gthread_mutex_unlock (&unit_lock);
1377 __gthread_mutex_lock (&u->lock);
1379 min_unit = u->unit_number + 1;
1384 __gthread_mutex_lock (&unit_lock);
1385 __gthread_mutex_unlock (&u->lock);
1386 (void) predec_waiting_locked (u);
1390 __gthread_mutex_lock (&unit_lock);
1391 __gthread_mutex_unlock (&u->lock);
1392 if (predec_waiting_locked (u) == 0)
1400 /* delete_file()-- Given a unit structure, delete the file associated
1401 * with the unit. Returns nonzero if something went wrong. */
1404 delete_file (gfc_unit * u)
1406 char path[PATH_MAX + 1];
1408 if (unpack_filename (path, u->file, u->file_len))
1409 { /* Shouldn't be possible */
1414 return unlink (path);
1418 /* file_exists()-- Returns nonzero if the current filename exists on
1422 file_exists (const char *file, gfc_charlen_type file_len)
1424 char path[PATH_MAX + 1];
1425 struct stat statbuf;
1427 if (unpack_filename (path, file, file_len))
1430 if (stat (path, &statbuf) < 0)
1438 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1440 /* inquire_sequential()-- Given a fortran string, determine if the
1441 * file is suitable for sequential access. Returns a C-style
1445 inquire_sequential (const char *string, int len)
1447 char path[PATH_MAX + 1];
1448 struct stat statbuf;
1450 if (string == NULL ||
1451 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1454 if (S_ISREG (statbuf.st_mode) ||
1455 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1458 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1465 /* inquire_direct()-- Given a fortran string, determine if the file is
1466 * suitable for direct access. Returns a C-style string. */
1469 inquire_direct (const char *string, int len)
1471 char path[PATH_MAX + 1];
1472 struct stat statbuf;
1474 if (string == NULL ||
1475 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1478 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1481 if (S_ISDIR (statbuf.st_mode) ||
1482 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1489 /* inquire_formatted()-- Given a fortran string, determine if the file
1490 * is suitable for formatted form. Returns a C-style string. */
1493 inquire_formatted (const char *string, int len)
1495 char path[PATH_MAX + 1];
1496 struct stat statbuf;
1498 if (string == NULL ||
1499 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1502 if (S_ISREG (statbuf.st_mode) ||
1503 S_ISBLK (statbuf.st_mode) ||
1504 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1507 if (S_ISDIR (statbuf.st_mode))
1514 /* inquire_unformatted()-- Given a fortran string, determine if the file
1515 * is suitable for unformatted form. Returns a C-style string. */
1518 inquire_unformatted (const char *string, int len)
1520 return inquire_formatted (string, len);
1534 /* Fallback implementation of access() on systems that don't have it.
1535 Only modes R_OK and W_OK are used in this file. */
1538 fallback_access (const char *path, int mode)
1540 if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1543 if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1550 #define access fallback_access
1554 /* inquire_access()-- Given a fortran string, determine if the file is
1555 * suitable for access. */
1558 inquire_access (const char *string, int len, int mode)
1560 char path[PATH_MAX + 1];
1562 if (string == NULL || unpack_filename (path, string, len) ||
1563 access (path, mode) < 0)
1570 /* inquire_read()-- Given a fortran string, determine if the file is
1571 * suitable for READ access. */
1574 inquire_read (const char *string, int len)
1576 return inquire_access (string, len, R_OK);
1580 /* inquire_write()-- Given a fortran string, determine if the file is
1581 * suitable for READ access. */
1584 inquire_write (const char *string, int len)
1586 return inquire_access (string, len, W_OK);
1590 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1591 * suitable for read and write access. */
1594 inquire_readwrite (const char *string, int len)
1596 return inquire_access (string, len, R_OK | W_OK);
1600 /* file_length()-- Return the file length in bytes, -1 if unknown */
1603 file_length (stream * s)
1606 if (!is_seekable (s))
1611 end = sseek (s, 0, SEEK_END);
1612 sseek (s, curr, SEEK_SET);
1617 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1621 is_seekable (stream *s)
1623 /* By convention, if file_length == -1, the file is not
1625 return ((unix_stream *) s)->file_length!=-1;
1629 /* is_special()-- Return nonzero if the stream is not a regular file. */
1632 is_special (stream *s)
1634 return ((unix_stream *) s)->special_file;
1639 stream_isatty (stream *s)
1641 return isatty (((unix_stream *) s)->fd);
1645 stream_ttyname (stream *s __attribute__ ((unused)))
1648 return ttyname (((unix_stream *) s)->fd);
1655 /* How files are stored: This is an operating-system specific issue,
1656 and therefore belongs here. There are three cases to consider.
1659 Records are written as block of bytes corresponding to the record
1660 length of the file. This goes for both formatted and unformatted
1661 records. Positioning is done explicitly for each data transfer,
1662 so positioning is not much of an issue.
1664 Sequential Formatted:
1665 Records are separated by newline characters. The newline character
1666 is prohibited from appearing in a string. If it does, this will be
1667 messed up on the next read. End of file is also the end of a record.
1669 Sequential Unformatted:
1670 In this case, we are merely copying bytes to and from main storage,
1671 yet we need to keep track of varying record lengths. We adopt
1672 the solution used by f2c. Each record contains a pair of length
1675 Length of record n in bytes
1677 Length of record n in bytes
1679 Length of record n+1 in bytes
1681 Length of record n+1 in bytes
1683 The length is stored at the end of a record to allow backspacing to the
1684 previous record. Between data transfer statements, the file pointer
1685 is left pointing to the first length of the current record.
1687 ENDFILE records are never explicitly stored.