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
115 /* These flags aren't defined on all targets (mingw32), so provide them
134 /* Unix and internal stream I/O module */
136 static const int BUFFER_SIZE = 8192;
142 gfc_offset buffer_offset; /* File offset of the start of the buffer */
143 gfc_offset physical_offset; /* Current physical file offset */
144 gfc_offset logical_offset; /* Current logical file offset */
145 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
147 char *buffer; /* Pointer to the buffer. */
148 int fd; /* The POSIX file descriptor. */
150 int active; /* Length of valid bytes in the buffer */
153 int ndirty; /* Dirty bytes starting at buffer_offset */
155 int special_file; /* =1 if the fd refers to a special file */
160 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
161 * standard descriptors, returning a non-standard descriptor. If the
162 * user specifies that system errors should go to standard output,
163 * then closes standard output, we don't want the system errors to a
164 * file that has been given file descriptor 1 or 0. We want to send
165 * the error to the invalid descriptor. */
171 int input, output, error;
173 input = output = error = 0;
175 /* Unix allocates the lowest descriptors first, so a loop is not
176 required, but this order is. */
177 if (fd == STDIN_FILENO)
182 if (fd == STDOUT_FILENO)
187 if (fd == STDERR_FILENO)
194 close (STDIN_FILENO);
196 close (STDOUT_FILENO);
198 close (STDERR_FILENO);
205 /* If the stream corresponds to a preconnected unit, we flush the
206 corresponding C stream. This is bugware for mixed C-Fortran codes
207 where the C code doesn't flush I/O before returning. */
209 flush_if_preconnected (stream * s)
213 fd = ((unix_stream *) s)->fd;
214 if (fd == STDIN_FILENO)
216 else if (fd == STDOUT_FILENO)
218 else if (fd == STDERR_FILENO)
223 /* get_oserror()-- Get the most recent operating system error. For
224 * unix, this is errno. */
229 return strerror (errno);
233 /********************************************************************
234 Raw I/O functions (read, write, seek, tell, truncate, close).
236 These functions wrap the basic POSIX I/O syscalls. Any deviation in
237 semantics is a bug, except the following: write restarts in case
238 of being interrupted by a signal, and as the first argument the
239 functions take the unix_stream struct rather than an integer file
240 descriptor. Also, for POSIX read() and write() a nbyte argument larger
241 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
242 than size_t as for POSIX read/write.
243 *********************************************************************/
246 raw_flush (unix_stream * s __attribute__ ((unused)))
252 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
254 /* For read we can't do I/O in a loop like raw_write does, because
255 that will break applications that wait for interactive I/O. */
256 return read (s->fd, buf, nbyte);
260 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
262 ssize_t trans, bytes_left;
266 buf_st = (char *) buf;
268 /* We must write in a loop since some systems don't restart system
269 calls in case of a signal. */
270 while (bytes_left > 0)
272 trans = write (s->fd, buf_st, bytes_left);
284 return nbyte - bytes_left;
288 raw_seek (unix_stream * s, gfc_offset offset, int whence)
290 return lseek (s->fd, offset, whence);
294 raw_tell (unix_stream * s)
296 return lseek (s->fd, 0, SEEK_CUR);
300 raw_truncate (unix_stream * s, gfc_offset length)
311 h = (HANDLE) _get_osfhandle (s->fd);
312 if (h == INVALID_HANDLE_VALUE)
317 cur = lseek (s->fd, 0, SEEK_CUR);
320 if (lseek (s->fd, length, SEEK_SET) == -1)
322 if (!SetEndOfFile (h))
327 if (lseek (s->fd, cur, SEEK_SET) == -1)
331 lseek (s->fd, cur, SEEK_SET);
333 #elif defined HAVE_FTRUNCATE
334 return ftruncate (s->fd, length);
335 #elif defined HAVE_CHSIZE
336 return chsize (s->fd, length);
338 runtime_error ("required ftruncate or chsize support not present");
344 raw_close (unix_stream * s)
348 if (s->fd != STDOUT_FILENO
349 && s->fd != STDERR_FILENO
350 && s->fd != STDIN_FILENO)
351 retval = close (s->fd);
359 raw_init (unix_stream * s)
361 s->st.read = (void *) raw_read;
362 s->st.write = (void *) raw_write;
363 s->st.seek = (void *) raw_seek;
364 s->st.tell = (void *) raw_tell;
365 s->st.trunc = (void *) raw_truncate;
366 s->st.close = (void *) raw_close;
367 s->st.flush = (void *) raw_flush;
374 /*********************************************************************
375 Buffered I/O functions. These functions have the same semantics as the
376 raw I/O functions above, except that they are buffered in order to
377 improve performance. The buffer must be flushed when switching from
378 reading to writing and vice versa.
379 *********************************************************************/
382 buf_flush (unix_stream * s)
386 /* Flushing in read mode means discarding read bytes. */
392 if (s->file_length != -1 && s->physical_offset != s->buffer_offset
393 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
396 writelen = raw_write (s, s->buffer, s->ndirty);
398 s->physical_offset = s->buffer_offset + writelen;
400 /* Don't increment file_length if the file is non-seekable. */
401 if (s->file_length != -1 && s->physical_offset > s->file_length)
402 s->file_length = s->physical_offset;
404 s->ndirty -= writelen;
416 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
419 s->buffer_offset = s->logical_offset;
421 /* Is the data we want in the buffer? */
422 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
423 && s->buffer_offset <= s->logical_offset)
424 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
427 /* First copy the active bytes if applicable, then read the rest
428 either directly or filling the buffer. */
431 ssize_t to_read, did_read;
432 gfc_offset new_logical;
435 if (s->logical_offset >= s->buffer_offset
436 && s->buffer_offset + s->active >= s->logical_offset)
438 nread = s->active - (s->logical_offset - s->buffer_offset);
439 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
443 /* At this point we consider all bytes in the buffer discarded. */
444 to_read = nbyte - nread;
445 new_logical = s->logical_offset + nread;
446 if (s->file_length != -1 && s->physical_offset != new_logical
447 && lseek (s->fd, new_logical, SEEK_SET) < 0)
449 s->buffer_offset = s->physical_offset = new_logical;
450 if (to_read <= BUFFER_SIZE/2)
452 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
453 s->physical_offset += did_read;
454 s->active = did_read;
455 did_read = (did_read > to_read) ? to_read : did_read;
456 memcpy (p, s->buffer, did_read);
460 did_read = raw_read (s, p, to_read);
461 s->physical_offset += did_read;
464 nbyte = did_read + nread;
466 s->logical_offset += nbyte;
471 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
474 s->buffer_offset = s->logical_offset;
476 /* Does the data fit into the buffer? As a special case, if the
477 buffer is empty and the request is bigger than BUFFER_SIZE/2,
478 write directly. This avoids the case where the buffer would have
479 to be flushed at every write. */
480 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
481 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
482 && s->buffer_offset <= s->logical_offset
483 && s->buffer_offset + s->ndirty >= s->logical_offset)
485 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
486 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
492 /* Flush, and either fill the buffer with the new data, or if
493 the request is bigger than the buffer size, write directly
494 bypassing the buffer. */
496 if (nbyte <= BUFFER_SIZE/2)
498 memcpy (s->buffer, buf, nbyte);
499 s->buffer_offset = s->logical_offset;
504 if (s->file_length != -1 && s->physical_offset != s->logical_offset)
506 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
508 s->physical_offset = s->logical_offset;
511 nbyte = raw_write (s, buf, nbyte);
512 s->physical_offset += nbyte;
515 s->logical_offset += nbyte;
516 /* Don't increment file_length if the file is non-seekable. */
517 if (s->file_length != -1 && s->logical_offset > s->file_length)
518 s->file_length = s->logical_offset;
523 buf_seek (unix_stream * s, gfc_offset offset, int whence)
530 offset += s->logical_offset;
533 offset += s->file_length;
543 s->logical_offset = offset;
548 buf_tell (unix_stream * s)
550 return s->logical_offset;
554 buf_truncate (unix_stream * s, gfc_offset length)
558 if (buf_flush (s) != 0)
560 r = raw_truncate (s, length);
562 s->file_length = length;
567 buf_close (unix_stream * s)
569 if (buf_flush (s) != 0)
572 return raw_close (s);
576 buf_init (unix_stream * s)
578 s->st.read = (void *) buf_read;
579 s->st.write = (void *) buf_write;
580 s->st.seek = (void *) buf_seek;
581 s->st.tell = (void *) buf_tell;
582 s->st.trunc = (void *) buf_truncate;
583 s->st.close = (void *) buf_close;
584 s->st.flush = (void *) buf_flush;
586 s->buffer = get_mem (BUFFER_SIZE);
591 /*********************************************************************
592 memory stream functions - These are used for internal files
594 The idea here is that a single stream structure is created and all
595 requests must be satisfied from it. The location and size of the
596 buffer is the character variable supplied to the READ or WRITE
599 *********************************************************************/
602 mem_alloc_r (stream * strm, int * len)
604 unix_stream * s = (unix_stream *) strm;
606 gfc_offset where = s->logical_offset;
608 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
611 n = s->buffer_offset + s->active - where;
615 s->logical_offset = where + *len;
617 return s->buffer + (where - s->buffer_offset);
622 mem_alloc_r4 (stream * strm, int * len)
624 unix_stream * s = (unix_stream *) strm;
626 gfc_offset where = s->logical_offset;
628 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
631 n = s->buffer_offset + s->active - where;
635 s->logical_offset = where + *len;
637 return s->buffer + (where - s->buffer_offset) * 4;
642 mem_alloc_w (stream * strm, int * len)
644 unix_stream * s = (unix_stream *) strm;
646 gfc_offset where = s->logical_offset;
650 if (where < s->buffer_offset)
653 if (m > s->file_length)
656 s->logical_offset = m;
658 return s->buffer + (where - s->buffer_offset);
663 mem_alloc_w4 (stream * strm, int * len)
665 unix_stream * s = (unix_stream *) strm;
667 gfc_offset where = s->logical_offset;
668 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
672 if (where < s->buffer_offset)
675 if (m > s->file_length)
678 s->logical_offset = m;
679 return &result[where - s->buffer_offset];
683 /* Stream read function for character(kine=1) internal units. */
686 mem_read (stream * s, void * buf, ssize_t nbytes)
691 p = mem_alloc_r (s, &nb);
702 /* Stream read function for chracter(kind=4) internal units. */
705 mem_read4 (stream * s, void * buf, ssize_t nbytes)
710 p = mem_alloc_r (s, &nb);
721 /* Stream write function for character(kind=1) internal units. */
724 mem_write (stream * s, const void * buf, ssize_t nbytes)
729 p = mem_alloc_w (s, &nb);
740 /* Stream write function for character(kind=4) internal units. */
743 mem_write4 (stream * s, const void * buf, ssize_t nwords)
748 p = mem_alloc_w4 (s, &nw);
752 *p++ = (gfc_char4_t) *((char *) buf);
761 mem_seek (stream * strm, gfc_offset offset, int whence)
763 unix_stream * s = (unix_stream *) strm;
769 offset += s->logical_offset;
772 offset += s->file_length;
778 /* Note that for internal array I/O it's actually possible to have a
779 negative offset, so don't check for that. */
780 if (offset > s->file_length)
786 s->logical_offset = offset;
788 /* Returning < 0 is the error indicator for sseek(), so return 0 if
789 offset is negative. Thus if the return value is 0, the caller
790 has to use stell() to get the real value of logical_offset. */
798 mem_tell (stream * s)
800 return ((unix_stream *)s)->logical_offset;
805 mem_truncate (unix_stream * s __attribute__ ((unused)),
806 gfc_offset length __attribute__ ((unused)))
813 mem_flush (unix_stream * s __attribute__ ((unused)))
820 mem_close (unix_stream * s)
829 /*********************************************************************
830 Public functions -- A reimplementation of this module needs to
831 define functional equivalents of the following.
832 *********************************************************************/
834 /* empty_internal_buffer()-- Zero the buffer of Internal file */
837 empty_internal_buffer(stream *strm)
839 unix_stream * s = (unix_stream *) strm;
840 memset(s->buffer, ' ', s->file_length);
843 /* open_internal()-- Returns a stream structure from a character(kind=1)
847 open_internal (char *base, int length, gfc_offset offset)
851 s = get_mem (sizeof (unix_stream));
852 memset (s, '\0', sizeof (unix_stream));
855 s->buffer_offset = offset;
857 s->logical_offset = 0;
858 s->active = s->file_length = length;
860 s->st.close = (void *) mem_close;
861 s->st.seek = (void *) mem_seek;
862 s->st.tell = (void *) mem_tell;
863 s->st.trunc = (void *) mem_truncate;
864 s->st.read = (void *) mem_read;
865 s->st.write = (void *) mem_write;
866 s->st.flush = (void *) mem_flush;
871 /* open_internal4()-- Returns a stream structure from a character(kind=4)
875 open_internal4 (char *base, int length, gfc_offset offset)
879 s = get_mem (sizeof (unix_stream));
880 memset (s, '\0', sizeof (unix_stream));
883 s->buffer_offset = offset;
885 s->logical_offset = 0;
886 s->active = s->file_length = length;
888 s->st.close = (void *) mem_close;
889 s->st.seek = (void *) mem_seek;
890 s->st.tell = (void *) mem_tell;
891 s->st.trunc = (void *) mem_truncate;
892 s->st.read = (void *) mem_read4;
893 s->st.write = (void *) mem_write4;
894 s->st.flush = (void *) mem_flush;
900 /* fd_to_stream()-- Given an open file descriptor, build a stream
904 fd_to_stream (int fd, int prot)
909 s = get_mem (sizeof (unix_stream));
910 memset (s, '\0', sizeof (unix_stream));
913 s->buffer_offset = 0;
914 s->physical_offset = 0;
915 s->logical_offset = 0;
918 /* Get the current length of the file. */
920 fstat (fd, &statbuf);
922 if (lseek (fd, 0, SEEK_CUR) == (gfc_offset) -1)
925 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
927 s->special_file = !S_ISREG (statbuf.st_mode);
929 if (isatty (s->fd) || options.all_unbuffered
930 ||(options.unbuffered_preconnected &&
931 (s->fd == STDIN_FILENO
932 || s->fd == STDOUT_FILENO
933 || s->fd == STDERR_FILENO)))
942 /* Given the Fortran unit number, convert it to a C file descriptor. */
945 unit_to_fd (int unit)
950 us = find_unit (unit);
954 fd = ((unix_stream *) us->s)->fd;
960 /* unpack_filename()-- Given a fortran string and a pointer to a
961 * buffer that is PATH_MAX characters, convert the fortran string to a
962 * C string in the buffer. Returns nonzero if this is not possible. */
965 unpack_filename (char *cstring, const char *fstring, int len)
967 len = fstrlen (fstring, len);
971 memmove (cstring, fstring, len);
978 /* tempfile()-- Generate a temporary filename for a scratch file and
979 * open it. mkstemp() opens the file for reading and writing, but the
980 * library mode prevents anything that is not allowed. The descriptor
981 * is returned, which is -1 on error. The template is pointed to by
982 * opp->file, which is copied into the unit structure
983 * and freed later. */
986 tempfile (st_parameter_open *opp)
990 const char *slash = "/";
993 tempdir = getenv ("GFORTRAN_TMPDIR");
997 char buffer[MAX_PATH + 1];
999 ret = GetTempPath (MAX_PATH, buffer);
1000 /* If we are not able to get a temp-directory, we use
1001 current directory. */
1002 if (ret > MAX_PATH || !ret)
1006 tempdir = strdup (buffer);
1009 if (tempdir == NULL)
1010 tempdir = getenv ("TMP");
1011 if (tempdir == NULL)
1012 tempdir = getenv ("TEMP");
1013 if (tempdir == NULL)
1014 tempdir = DEFAULT_TEMPDIR;
1016 /* Check for special case that tempdir contains slash
1017 or backslash at end. */
1018 if (*tempdir == 0 || tempdir[strlen (tempdir) - 1] == '/'
1020 || tempdir[strlen (tempdir) - 1] == '\\'
1025 template = get_mem (strlen (tempdir) + 20);
1028 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
1030 fd = mkstemp (template);
1032 #else /* HAVE_MKSTEMP */
1036 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
1037 if (!mktemp (template))
1039 #if defined(HAVE_CRLF) && defined(O_BINARY)
1040 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1041 S_IREAD | S_IWRITE);
1043 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1046 while (fd == -1 && errno == EEXIST);
1047 #endif /* HAVE_MKSTEMP */
1053 opp->file = template;
1054 opp->file_len = strlen (template); /* Don't include trailing nul */
1061 /* regular_file()-- Open a regular file.
1062 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1063 * unless an error occurs.
1064 * Returns the descriptor, which is less than zero on error. */
1067 regular_file (st_parameter_open *opp, unit_flags *flags)
1069 char path[PATH_MAX + 1];
1075 if (unpack_filename (path, opp->file, opp->file_len))
1077 errno = ENOENT; /* Fake an OS error */
1082 if (opp->file_len == 7)
1084 if (strncmp (path, "CONOUT$", 7) == 0
1085 || strncmp (path, "CONERR$", 7) == 0)
1087 fd = open ("/dev/conout", O_WRONLY);
1088 flags->action = ACTION_WRITE;
1093 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1095 fd = open ("/dev/conin", O_RDONLY);
1096 flags->action = ACTION_READ;
1103 if (opp->file_len == 7)
1105 if (strncmp (path, "CONOUT$", 7) == 0
1106 || strncmp (path, "CONERR$", 7) == 0)
1108 fd = open ("CONOUT$", O_WRONLY);
1109 flags->action = ACTION_WRITE;
1114 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1116 fd = open ("CONIN$", O_RDONLY);
1117 flags->action = ACTION_READ;
1124 switch (flags->action)
1134 case ACTION_READWRITE:
1135 case ACTION_UNSPECIFIED:
1140 internal_error (&opp->common, "regular_file(): Bad action");
1143 switch (flags->status)
1146 crflag = O_CREAT | O_EXCL;
1149 case STATUS_OLD: /* open will fail if the file does not exist*/
1153 case STATUS_UNKNOWN:
1154 case STATUS_SCRATCH:
1158 case STATUS_REPLACE:
1159 crflag = O_CREAT | O_TRUNC;
1163 internal_error (&opp->common, "regular_file(): Bad status");
1166 /* rwflag |= O_LARGEFILE; */
1168 #if defined(HAVE_CRLF) && defined(O_BINARY)
1172 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1173 fd = open (path, rwflag | crflag, mode);
1174 if (flags->action != ACTION_UNSPECIFIED)
1179 flags->action = ACTION_READWRITE;
1182 if (errno != EACCES && errno != EROFS)
1185 /* retry for read-only access */
1187 fd = open (path, rwflag | crflag, mode);
1190 flags->action = ACTION_READ;
1191 return fd; /* success */
1194 if (errno != EACCES)
1195 return fd; /* failure */
1197 /* retry for write-only access */
1199 fd = open (path, rwflag | crflag, mode);
1202 flags->action = ACTION_WRITE;
1203 return fd; /* success */
1205 return fd; /* failure */
1209 /* open_external()-- Open an external file, unix specific version.
1210 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1211 * Returns NULL on operating system error. */
1214 open_external (st_parameter_open *opp, unit_flags *flags)
1218 if (flags->status == STATUS_SCRATCH)
1220 fd = tempfile (opp);
1221 if (flags->action == ACTION_UNSPECIFIED)
1222 flags->action = ACTION_READWRITE;
1224 #if HAVE_UNLINK_OPEN_FILE
1225 /* We can unlink scratch files now and it will go away when closed. */
1232 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1234 fd = regular_file (opp, flags);
1241 switch (flags->action)
1251 case ACTION_READWRITE:
1252 prot = PROT_READ | PROT_WRITE;
1256 internal_error (&opp->common, "open_external(): Bad action");
1259 return fd_to_stream (fd, prot);
1263 /* input_stream()-- Return a stream pointer to the default input stream.
1264 * Called on initialization. */
1269 return fd_to_stream (STDIN_FILENO, PROT_READ);
1273 /* output_stream()-- Return a stream pointer to the default output stream.
1274 * Called on initialization. */
1277 output_stream (void)
1281 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1282 setmode (STDOUT_FILENO, O_BINARY);
1285 s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1290 /* error_stream()-- Return a stream pointer to the default error stream.
1291 * Called on initialization. */
1298 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1299 setmode (STDERR_FILENO, O_BINARY);
1302 s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1307 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1308 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1309 is big enough to completely fill a 80x25 terminal, so it shuld be
1310 OK. We use a direct write() because it is simpler and least likely
1311 to be clobbered by memory corruption. Writing an error message
1312 longer than that is an error. */
1314 #define ST_VPRINTF_SIZE 2048
1317 st_vprintf (const char *format, va_list ap)
1319 static char buffer[ST_VPRINTF_SIZE];
1323 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1324 #ifdef HAVE_VSNPRINTF
1325 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1327 written = vsprintf(buffer, format, ap);
1329 if (written >= ST_VPRINTF_SIZE-1)
1331 /* The error message was longer than our buffer. Ouch. Because
1332 we may have messed up things badly, report the error and
1334 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1335 write (fd, buffer, ST_VPRINTF_SIZE-1);
1336 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1338 #undef ERROR_MESSAGE
1343 written = write (fd, buffer, written);
1347 /* st_printf()-- printf() function for error output. This just calls
1348 st_vprintf() to do the actual work. */
1351 st_printf (const char *format, ...)
1355 va_start (ap, format);
1356 written = st_vprintf(format, ap);
1362 /* compare_file_filename()-- Given an open stream and a fortran string
1363 * that is a filename, figure out if the file is the same as the
1367 compare_file_filename (gfc_unit *u, const char *name, int len)
1369 char path[PATH_MAX + 1];
1371 #ifdef HAVE_WORKING_STAT
1379 if (unpack_filename (path, name, len))
1380 return 0; /* Can't be the same */
1382 /* If the filename doesn't exist, then there is no match with the
1385 if (stat (path, &st1) < 0)
1388 #ifdef HAVE_WORKING_STAT
1389 fstat (((unix_stream *) (u->s))->fd, &st2);
1390 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1394 /* We try to match files by a unique ID. On some filesystems (network
1395 fs and FAT), we can't generate this unique ID, and will simply compare
1397 id1 = id_from_path (path);
1398 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1400 return (id1 == id2);
1403 if (len != u->file_len)
1405 return (memcmp(path, u->file, len) == 0);
1410 #ifdef HAVE_WORKING_STAT
1411 # define FIND_FILE0_DECL gfstat_t *st
1412 # define FIND_FILE0_ARGS st
1414 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1415 # define FIND_FILE0_ARGS id, file, file_len
1418 /* find_file0()-- Recursive work function for find_file() */
1421 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1424 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1431 #ifdef HAVE_WORKING_STAT
1433 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1434 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1438 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1445 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1449 v = find_file0 (u->left, FIND_FILE0_ARGS);
1453 v = find_file0 (u->right, FIND_FILE0_ARGS);
1461 /* find_file()-- Take the current filename and see if there is a unit
1462 * that has the file already open. Returns a pointer to the unit if so. */
1465 find_file (const char *file, gfc_charlen_type file_len)
1467 char path[PATH_MAX + 1];
1470 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1474 if (unpack_filename (path, file, file_len))
1477 if (stat (path, &st[0]) < 0)
1480 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1481 id = id_from_path (path);
1484 __gthread_mutex_lock (&unit_lock);
1486 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1490 if (! __gthread_mutex_trylock (&u->lock))
1492 /* assert (u->closed == 0); */
1493 __gthread_mutex_unlock (&unit_lock);
1497 inc_waiting_locked (u);
1499 __gthread_mutex_unlock (&unit_lock);
1502 __gthread_mutex_lock (&u->lock);
1505 __gthread_mutex_lock (&unit_lock);
1506 __gthread_mutex_unlock (&u->lock);
1507 if (predec_waiting_locked (u) == 0)
1512 dec_waiting_unlocked (u);
1518 flush_all_units_1 (gfc_unit *u, int min_unit)
1522 if (u->unit_number > min_unit)
1524 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1528 if (u->unit_number >= min_unit)
1530 if (__gthread_mutex_trylock (&u->lock))
1534 __gthread_mutex_unlock (&u->lock);
1542 flush_all_units (void)
1547 __gthread_mutex_lock (&unit_lock);
1550 u = flush_all_units_1 (unit_root, min_unit);
1552 inc_waiting_locked (u);
1553 __gthread_mutex_unlock (&unit_lock);
1557 __gthread_mutex_lock (&u->lock);
1559 min_unit = u->unit_number + 1;
1564 __gthread_mutex_lock (&unit_lock);
1565 __gthread_mutex_unlock (&u->lock);
1566 (void) predec_waiting_locked (u);
1570 __gthread_mutex_lock (&unit_lock);
1571 __gthread_mutex_unlock (&u->lock);
1572 if (predec_waiting_locked (u) == 0)
1580 /* delete_file()-- Given a unit structure, delete the file associated
1581 * with the unit. Returns nonzero if something went wrong. */
1584 delete_file (gfc_unit * u)
1586 char path[PATH_MAX + 1];
1588 if (unpack_filename (path, u->file, u->file_len))
1589 { /* Shouldn't be possible */
1594 return unlink (path);
1598 /* file_exists()-- Returns nonzero if the current filename exists on
1602 file_exists (const char *file, gfc_charlen_type file_len)
1604 char path[PATH_MAX + 1];
1607 if (unpack_filename (path, file, file_len))
1610 if (stat (path, &statbuf) < 0)
1617 /* file_size()-- Returns the size of the file. */
1620 file_size (const char *file, gfc_charlen_type file_len)
1622 char path[PATH_MAX + 1];
1625 if (unpack_filename (path, file, file_len))
1628 if (stat (path, &statbuf) < 0)
1631 return (GFC_IO_INT) statbuf.st_size;
1634 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1636 /* inquire_sequential()-- Given a fortran string, determine if the
1637 * file is suitable for sequential access. Returns a C-style
1641 inquire_sequential (const char *string, int len)
1643 char path[PATH_MAX + 1];
1646 if (string == NULL ||
1647 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1650 if (S_ISREG (statbuf.st_mode) ||
1651 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1654 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1661 /* inquire_direct()-- Given a fortran string, determine if the file is
1662 * suitable for direct access. Returns a C-style string. */
1665 inquire_direct (const char *string, int len)
1667 char path[PATH_MAX + 1];
1670 if (string == NULL ||
1671 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1674 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1677 if (S_ISDIR (statbuf.st_mode) ||
1678 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1685 /* inquire_formatted()-- Given a fortran string, determine if the file
1686 * is suitable for formatted form. Returns a C-style string. */
1689 inquire_formatted (const char *string, int len)
1691 char path[PATH_MAX + 1];
1694 if (string == NULL ||
1695 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1698 if (S_ISREG (statbuf.st_mode) ||
1699 S_ISBLK (statbuf.st_mode) ||
1700 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1703 if (S_ISDIR (statbuf.st_mode))
1710 /* inquire_unformatted()-- Given a fortran string, determine if the file
1711 * is suitable for unformatted form. Returns a C-style string. */
1714 inquire_unformatted (const char *string, int len)
1716 return inquire_formatted (string, len);
1730 /* Fallback implementation of access() on systems that don't have it.
1731 Only modes R_OK and W_OK are used in this file. */
1734 fallback_access (const char *path, int mode)
1736 if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1739 if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1746 #define access fallback_access
1750 /* inquire_access()-- Given a fortran string, determine if the file is
1751 * suitable for access. */
1754 inquire_access (const char *string, int len, int mode)
1756 char path[PATH_MAX + 1];
1758 if (string == NULL || unpack_filename (path, string, len) ||
1759 access (path, mode) < 0)
1766 /* inquire_read()-- Given a fortran string, determine if the file is
1767 * suitable for READ access. */
1770 inquire_read (const char *string, int len)
1772 return inquire_access (string, len, R_OK);
1776 /* inquire_write()-- Given a fortran string, determine if the file is
1777 * suitable for READ access. */
1780 inquire_write (const char *string, int len)
1782 return inquire_access (string, len, W_OK);
1786 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1787 * suitable for read and write access. */
1790 inquire_readwrite (const char *string, int len)
1792 return inquire_access (string, len, R_OK | W_OK);
1796 /* file_length()-- Return the file length in bytes, -1 if unknown */
1799 file_length (stream * s)
1801 gfc_offset curr, end;
1802 if (!is_seekable (s))
1807 end = sseek (s, 0, SEEK_END);
1808 sseek (s, curr, SEEK_SET);
1813 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1817 is_seekable (stream *s)
1819 /* By convention, if file_length == -1, the file is not
1821 return ((unix_stream *) s)->file_length!=-1;
1825 /* is_special()-- Return nonzero if the stream is not a regular file. */
1828 is_special (stream *s)
1830 return ((unix_stream *) s)->special_file;
1835 stream_isatty (stream *s)
1837 return isatty (((unix_stream *) s)->fd);
1841 stream_ttyname (stream *s __attribute__ ((unused)))
1844 return ttyname (((unix_stream *) s)->fd);
1851 /* How files are stored: This is an operating-system specific issue,
1852 and therefore belongs here. There are three cases to consider.
1855 Records are written as block of bytes corresponding to the record
1856 length of the file. This goes for both formatted and unformatted
1857 records. Positioning is done explicitly for each data transfer,
1858 so positioning is not much of an issue.
1860 Sequential Formatted:
1861 Records are separated by newline characters. The newline character
1862 is prohibited from appearing in a string. If it does, this will be
1863 messed up on the next read. End of file is also the end of a record.
1865 Sequential Unformatted:
1866 In this case, we are merely copying bytes to and from main storage,
1867 yet we need to keep track of varying record lengths. We adopt
1868 the solution used by f2c. Each record contains a pair of length
1871 Length of record n in bytes
1873 Length of record n in bytes
1875 Length of record n+1 in bytes
1877 Length of record n+1 in bytes
1879 The length is stored at the end of a record to allow backspacing to the
1880 previous record. Between data transfer statements, the file pointer
1881 is left pointing to the first length of the current record.
1883 ENDFILE records are never explicitly stored.