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;
170 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
171 * standard descriptors, returning a non-standard descriptor. If the
172 * user specifies that system errors should go to standard output,
173 * then closes standard output, we don't want the system errors to a
174 * file that has been given file descriptor 1 or 0. We want to send
175 * the error to the invalid descriptor. */
181 int input, output, error;
183 input = output = error = 0;
185 /* Unix allocates the lowest descriptors first, so a loop is not
186 required, but this order is. */
187 if (fd == STDIN_FILENO)
192 if (fd == STDOUT_FILENO)
197 if (fd == STDERR_FILENO)
204 close (STDIN_FILENO);
206 close (STDOUT_FILENO);
208 close (STDERR_FILENO);
215 /* If the stream corresponds to a preconnected unit, we flush the
216 corresponding C stream. This is bugware for mixed C-Fortran codes
217 where the C code doesn't flush I/O before returning. */
219 flush_if_preconnected (stream * s)
223 fd = ((unix_stream *) s)->fd;
224 if (fd == STDIN_FILENO)
226 else if (fd == STDOUT_FILENO)
228 else if (fd == STDERR_FILENO)
233 /* get_oserror()-- Get the most recent operating system error. For
234 * unix, this is errno. */
239 return strerror (errno);
243 /********************************************************************
244 Raw I/O functions (read, write, seek, tell, truncate, close).
246 These functions wrap the basic POSIX I/O syscalls. Any deviation in
247 semantics is a bug, except the following: write restarts in case
248 of being interrupted by a signal, and as the first argument the
249 functions take the unix_stream struct rather than an integer file
250 descriptor. Also, for POSIX read() and write() a nbyte argument larger
251 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
252 than size_t as for POSIX read/write.
253 *********************************************************************/
256 raw_flush (unix_stream * s __attribute__ ((unused)))
262 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
264 /* For read we can't do I/O in a loop like raw_write does, because
265 that will break applications that wait for interactive I/O. */
266 return read (s->fd, buf, nbyte);
270 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
272 ssize_t trans, bytes_left;
276 buf_st = (char *) buf;
278 /* We must write in a loop since some systems don't restart system
279 calls in case of a signal. */
280 while (bytes_left > 0)
282 trans = write (s->fd, buf_st, bytes_left);
294 return nbyte - bytes_left;
298 raw_seek (unix_stream * s, gfc_offset offset, int whence)
300 return lseek (s->fd, offset, whence);
304 raw_tell (unix_stream * s)
306 return lseek (s->fd, 0, SEEK_CUR);
310 raw_truncate (unix_stream * s, gfc_offset length)
321 h = (HANDLE) _get_osfhandle (s->fd);
322 if (h == INVALID_HANDLE_VALUE)
327 cur = lseek (s->fd, 0, SEEK_CUR);
330 if (lseek (s->fd, length, SEEK_SET) == -1)
332 if (!SetEndOfFile (h))
337 if (lseek (s->fd, cur, SEEK_SET) == -1)
341 lseek (s->fd, cur, SEEK_SET);
343 #elif defined HAVE_FTRUNCATE
344 return ftruncate (s->fd, length);
345 #elif defined HAVE_CHSIZE
346 return chsize (s->fd, length);
348 runtime_error ("required ftruncate or chsize support not present");
354 raw_close (unix_stream * s)
358 if (s->fd != STDOUT_FILENO
359 && s->fd != STDERR_FILENO
360 && s->fd != STDIN_FILENO)
361 retval = close (s->fd);
369 raw_init (unix_stream * s)
371 s->st.read = (void *) raw_read;
372 s->st.write = (void *) raw_write;
373 s->st.seek = (void *) raw_seek;
374 s->st.tell = (void *) raw_tell;
375 s->st.trunc = (void *) raw_truncate;
376 s->st.close = (void *) raw_close;
377 s->st.flush = (void *) raw_flush;
384 /*********************************************************************
385 Buffered I/O functions. These functions have the same semantics as the
386 raw I/O functions above, except that they are buffered in order to
387 improve performance. The buffer must be flushed when switching from
388 reading to writing and vice versa.
389 *********************************************************************/
392 buf_flush (unix_stream * s)
396 /* Flushing in read mode means discarding read bytes. */
402 if (s->file_length != -1 && s->physical_offset != s->buffer_offset
403 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
406 writelen = raw_write (s, s->buffer, s->ndirty);
408 s->physical_offset = s->buffer_offset + writelen;
410 /* Don't increment file_length if the file is non-seekable. */
411 if (s->file_length != -1 && s->physical_offset > s->file_length)
412 s->file_length = s->physical_offset;
414 s->ndirty -= writelen;
426 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
429 s->buffer_offset = s->logical_offset;
431 /* Is the data we want in the buffer? */
432 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
433 && s->buffer_offset <= s->logical_offset)
434 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
437 /* First copy the active bytes if applicable, then read the rest
438 either directly or filling the buffer. */
441 ssize_t to_read, did_read;
442 gfc_offset new_logical;
445 if (s->logical_offset >= s->buffer_offset
446 && s->buffer_offset + s->active >= s->logical_offset)
448 nread = s->active - (s->logical_offset - s->buffer_offset);
449 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
453 /* At this point we consider all bytes in the buffer discarded. */
454 to_read = nbyte - nread;
455 new_logical = s->logical_offset + nread;
456 if (s->file_length != -1 && s->physical_offset != new_logical
457 && lseek (s->fd, new_logical, SEEK_SET) < 0)
459 s->buffer_offset = s->physical_offset = new_logical;
460 if (to_read <= BUFFER_SIZE/2)
462 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
463 s->physical_offset += did_read;
464 s->active = did_read;
465 did_read = (did_read > to_read) ? to_read : did_read;
466 memcpy (p, s->buffer, did_read);
470 did_read = raw_read (s, p, to_read);
471 s->physical_offset += did_read;
474 nbyte = did_read + nread;
476 s->logical_offset += nbyte;
481 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
484 s->buffer_offset = s->logical_offset;
486 /* Does the data fit into the buffer? As a special case, if the
487 buffer is empty and the request is bigger than BUFFER_SIZE/2,
488 write directly. This avoids the case where the buffer would have
489 to be flushed at every write. */
490 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
491 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
492 && s->buffer_offset <= s->logical_offset
493 && s->buffer_offset + s->ndirty >= s->logical_offset)
495 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
496 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
502 /* Flush, and either fill the buffer with the new data, or if
503 the request is bigger than the buffer size, write directly
504 bypassing the buffer. */
506 if (nbyte <= BUFFER_SIZE/2)
508 memcpy (s->buffer, buf, nbyte);
509 s->buffer_offset = s->logical_offset;
514 if (s->file_length != -1 && s->physical_offset != s->logical_offset)
516 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
518 s->physical_offset = s->logical_offset;
521 nbyte = raw_write (s, buf, nbyte);
522 s->physical_offset += nbyte;
525 s->logical_offset += nbyte;
526 /* Don't increment file_length if the file is non-seekable. */
527 if (s->file_length != -1 && s->logical_offset > s->file_length)
528 s->file_length = s->logical_offset;
533 buf_seek (unix_stream * s, gfc_offset offset, int whence)
540 offset += s->logical_offset;
543 offset += s->file_length;
553 s->logical_offset = offset;
558 buf_tell (unix_stream * s)
560 return s->logical_offset;
564 buf_truncate (unix_stream * s, gfc_offset length)
568 if (buf_flush (s) != 0)
570 r = raw_truncate (s, length);
572 s->file_length = length;
577 buf_close (unix_stream * s)
579 if (buf_flush (s) != 0)
582 return raw_close (s);
586 buf_init (unix_stream * s)
588 s->st.read = (void *) buf_read;
589 s->st.write = (void *) buf_write;
590 s->st.seek = (void *) buf_seek;
591 s->st.tell = (void *) buf_tell;
592 s->st.trunc = (void *) buf_truncate;
593 s->st.close = (void *) buf_close;
594 s->st.flush = (void *) buf_flush;
596 s->buffer = get_mem (BUFFER_SIZE);
601 /*********************************************************************
602 memory stream functions - These are used for internal files
604 The idea here is that a single stream structure is created and all
605 requests must be satisfied from it. The location and size of the
606 buffer is the character variable supplied to the READ or WRITE
609 *********************************************************************/
612 mem_alloc_r (stream * strm, int * len)
614 unix_stream * s = (unix_stream *) strm;
616 gfc_offset where = s->logical_offset;
618 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
621 n = s->buffer_offset + s->active - where;
625 s->logical_offset = where + *len;
627 return s->buffer + (where - s->buffer_offset);
632 mem_alloc_r4 (stream * strm, int * len)
634 unix_stream * s = (unix_stream *) strm;
636 gfc_offset where = s->logical_offset;
638 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
641 n = s->buffer_offset + s->active - where;
645 s->logical_offset = where + *len;
647 return s->buffer + (where - s->buffer_offset) * 4;
652 mem_alloc_w (stream * strm, int * len)
654 unix_stream * s = (unix_stream *) strm;
656 gfc_offset where = s->logical_offset;
660 if (where < s->buffer_offset)
663 if (m > s->file_length)
666 s->logical_offset = m;
668 return s->buffer + (where - s->buffer_offset);
673 mem_alloc_w4 (stream * strm, int * len)
675 unix_stream * s = (unix_stream *) strm;
677 gfc_offset where = s->logical_offset;
678 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
682 if (where < s->buffer_offset)
685 if (m > s->file_length)
688 s->logical_offset = m;
689 return &result[where - s->buffer_offset];
693 /* Stream read function for character(kine=1) internal units. */
696 mem_read (stream * s, void * buf, ssize_t nbytes)
701 p = mem_alloc_r (s, &nb);
712 /* Stream read function for chracter(kind=4) internal units. */
715 mem_read4 (stream * s, void * buf, ssize_t nbytes)
720 p = mem_alloc_r (s, &nb);
731 /* Stream write function for character(kind=1) internal units. */
734 mem_write (stream * s, const void * buf, ssize_t nbytes)
739 p = mem_alloc_w (s, &nb);
750 /* Stream write function for character(kind=4) internal units. */
753 mem_write4 (stream * s, const void * buf, ssize_t nwords)
758 p = mem_alloc_w4 (s, &nw);
762 *p++ = (gfc_char4_t) *((char *) buf);
771 mem_seek (stream * strm, gfc_offset offset, int whence)
773 unix_stream * s = (unix_stream *) strm;
779 offset += s->logical_offset;
782 offset += s->file_length;
788 /* Note that for internal array I/O it's actually possible to have a
789 negative offset, so don't check for that. */
790 if (offset > s->file_length)
796 s->logical_offset = offset;
798 /* Returning < 0 is the error indicator for sseek(), so return 0 if
799 offset is negative. Thus if the return value is 0, the caller
800 has to use stell() to get the real value of logical_offset. */
808 mem_tell (stream * s)
810 return ((unix_stream *)s)->logical_offset;
815 mem_truncate (unix_stream * s __attribute__ ((unused)),
816 gfc_offset length __attribute__ ((unused)))
823 mem_flush (unix_stream * s __attribute__ ((unused)))
830 mem_close (unix_stream * s)
839 /*********************************************************************
840 Public functions -- A reimplementation of this module needs to
841 define functional equivalents of the following.
842 *********************************************************************/
844 /* open_internal()-- Returns a stream structure from a character(kind=1)
848 open_internal (char *base, int length, gfc_offset offset)
852 s = get_mem (sizeof (unix_stream));
853 memset (s, '\0', sizeof (unix_stream));
856 s->buffer_offset = offset;
858 s->logical_offset = 0;
859 s->active = s->file_length = length;
861 s->st.close = (void *) mem_close;
862 s->st.seek = (void *) mem_seek;
863 s->st.tell = (void *) mem_tell;
864 s->st.trunc = (void *) mem_truncate;
865 s->st.read = (void *) mem_read;
866 s->st.write = (void *) mem_write;
867 s->st.flush = (void *) mem_flush;
872 /* open_internal4()-- Returns a stream structure from a character(kind=4)
876 open_internal4 (char *base, int length, gfc_offset offset)
880 s = get_mem (sizeof (unix_stream));
881 memset (s, '\0', sizeof (unix_stream));
884 s->buffer_offset = offset;
886 s->logical_offset = 0;
887 s->active = s->file_length = length;
889 s->st.close = (void *) mem_close;
890 s->st.seek = (void *) mem_seek;
891 s->st.tell = (void *) mem_tell;
892 s->st.trunc = (void *) mem_truncate;
893 s->st.read = (void *) mem_read4;
894 s->st.write = (void *) mem_write4;
895 s->st.flush = (void *) mem_flush;
901 /* fd_to_stream()-- Given an open file descriptor, build a stream
905 fd_to_stream (int fd)
910 s = get_mem (sizeof (unix_stream));
911 memset (s, '\0', sizeof (unix_stream));
914 s->buffer_offset = 0;
915 s->physical_offset = 0;
916 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 return fd_to_stream (fd);
1245 /* input_stream()-- Return a stream pointer to the default input stream.
1246 * Called on initialization. */
1251 return fd_to_stream (STDIN_FILENO);
1255 /* output_stream()-- Return a stream pointer to the default output stream.
1256 * Called on initialization. */
1259 output_stream (void)
1263 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1264 setmode (STDOUT_FILENO, O_BINARY);
1267 s = fd_to_stream (STDOUT_FILENO);
1272 /* error_stream()-- Return a stream pointer to the default error stream.
1273 * Called on initialization. */
1280 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1281 setmode (STDERR_FILENO, O_BINARY);
1284 s = fd_to_stream (STDERR_FILENO);
1289 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1290 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1291 is big enough to completely fill a 80x25 terminal, so it shuld be
1292 OK. We use a direct write() because it is simpler and least likely
1293 to be clobbered by memory corruption. Writing an error message
1294 longer than that is an error. */
1296 #define ST_VPRINTF_SIZE 2048
1299 st_vprintf (const char *format, va_list ap)
1301 static char buffer[ST_VPRINTF_SIZE];
1305 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1306 #ifdef HAVE_VSNPRINTF
1307 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1309 written = vsprintf(buffer, format, ap);
1311 if (written >= ST_VPRINTF_SIZE-1)
1313 /* The error message was longer than our buffer. Ouch. Because
1314 we may have messed up things badly, report the error and
1316 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1317 write (fd, buffer, ST_VPRINTF_SIZE-1);
1318 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1320 #undef ERROR_MESSAGE
1325 written = write (fd, buffer, written);
1329 /* st_printf()-- printf() function for error output. This just calls
1330 st_vprintf() to do the actual work. */
1333 st_printf (const char *format, ...)
1337 va_start (ap, format);
1338 written = st_vprintf(format, ap);
1344 /* compare_file_filename()-- Given an open stream and a fortran string
1345 * that is a filename, figure out if the file is the same as the
1349 compare_file_filename (gfc_unit *u, const char *name, int len)
1351 char path[PATH_MAX + 1];
1353 #ifdef HAVE_WORKING_STAT
1361 if (unpack_filename (path, name, len))
1362 return 0; /* Can't be the same */
1364 /* If the filename doesn't exist, then there is no match with the
1367 if (stat (path, &st1) < 0)
1370 #ifdef HAVE_WORKING_STAT
1371 fstat (((unix_stream *) (u->s))->fd, &st2);
1372 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1376 /* We try to match files by a unique ID. On some filesystems (network
1377 fs and FAT), we can't generate this unique ID, and will simply compare
1379 id1 = id_from_path (path);
1380 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1382 return (id1 == id2);
1385 if (len != u->file_len)
1387 return (memcmp(path, u->file, len) == 0);
1392 #ifdef HAVE_WORKING_STAT
1393 # define FIND_FILE0_DECL gfstat_t *st
1394 # define FIND_FILE0_ARGS st
1396 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1397 # define FIND_FILE0_ARGS id, file, file_len
1400 /* find_file0()-- Recursive work function for find_file() */
1403 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1406 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1413 #ifdef HAVE_WORKING_STAT
1415 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1416 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1420 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1427 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1431 v = find_file0 (u->left, FIND_FILE0_ARGS);
1435 v = find_file0 (u->right, FIND_FILE0_ARGS);
1443 /* find_file()-- Take the current filename and see if there is a unit
1444 * that has the file already open. Returns a pointer to the unit if so. */
1447 find_file (const char *file, gfc_charlen_type file_len)
1449 char path[PATH_MAX + 1];
1452 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1456 if (unpack_filename (path, file, file_len))
1459 if (stat (path, &st[0]) < 0)
1462 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1463 id = id_from_path (path);
1466 __gthread_mutex_lock (&unit_lock);
1468 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1472 if (! __gthread_mutex_trylock (&u->lock))
1474 /* assert (u->closed == 0); */
1475 __gthread_mutex_unlock (&unit_lock);
1479 inc_waiting_locked (u);
1481 __gthread_mutex_unlock (&unit_lock);
1484 __gthread_mutex_lock (&u->lock);
1487 __gthread_mutex_lock (&unit_lock);
1488 __gthread_mutex_unlock (&u->lock);
1489 if (predec_waiting_locked (u) == 0)
1494 dec_waiting_unlocked (u);
1500 flush_all_units_1 (gfc_unit *u, int min_unit)
1504 if (u->unit_number > min_unit)
1506 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1510 if (u->unit_number >= min_unit)
1512 if (__gthread_mutex_trylock (&u->lock))
1516 __gthread_mutex_unlock (&u->lock);
1524 flush_all_units (void)
1529 __gthread_mutex_lock (&unit_lock);
1532 u = flush_all_units_1 (unit_root, min_unit);
1534 inc_waiting_locked (u);
1535 __gthread_mutex_unlock (&unit_lock);
1539 __gthread_mutex_lock (&u->lock);
1541 min_unit = u->unit_number + 1;
1546 __gthread_mutex_lock (&unit_lock);
1547 __gthread_mutex_unlock (&u->lock);
1548 (void) predec_waiting_locked (u);
1552 __gthread_mutex_lock (&unit_lock);
1553 __gthread_mutex_unlock (&u->lock);
1554 if (predec_waiting_locked (u) == 0)
1562 /* delete_file()-- Given a unit structure, delete the file associated
1563 * with the unit. Returns nonzero if something went wrong. */
1566 delete_file (gfc_unit * u)
1568 char path[PATH_MAX + 1];
1570 if (unpack_filename (path, u->file, u->file_len))
1571 { /* Shouldn't be possible */
1576 return unlink (path);
1580 /* file_exists()-- Returns nonzero if the current filename exists on
1584 file_exists (const char *file, gfc_charlen_type file_len)
1586 char path[PATH_MAX + 1];
1588 if (unpack_filename (path, file, file_len))
1591 return !(access (path, F_OK));
1595 /* file_size()-- Returns the size of the file. */
1598 file_size (const char *file, gfc_charlen_type file_len)
1600 char path[PATH_MAX + 1];
1603 if (unpack_filename (path, file, file_len))
1606 if (stat (path, &statbuf) < 0)
1609 return (GFC_IO_INT) statbuf.st_size;
1612 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1614 /* inquire_sequential()-- Given a fortran string, determine if the
1615 * file is suitable for sequential access. Returns a C-style
1619 inquire_sequential (const char *string, int len)
1621 char path[PATH_MAX + 1];
1624 if (string == NULL ||
1625 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1628 if (S_ISREG (statbuf.st_mode) ||
1629 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1632 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1639 /* inquire_direct()-- Given a fortran string, determine if the file is
1640 * suitable for direct access. Returns a C-style string. */
1643 inquire_direct (const char *string, int len)
1645 char path[PATH_MAX + 1];
1648 if (string == NULL ||
1649 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1652 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1655 if (S_ISDIR (statbuf.st_mode) ||
1656 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1663 /* inquire_formatted()-- Given a fortran string, determine if the file
1664 * is suitable for formatted form. Returns a C-style string. */
1667 inquire_formatted (const char *string, int len)
1669 char path[PATH_MAX + 1];
1672 if (string == NULL ||
1673 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1676 if (S_ISREG (statbuf.st_mode) ||
1677 S_ISBLK (statbuf.st_mode) ||
1678 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1681 if (S_ISDIR (statbuf.st_mode))
1688 /* inquire_unformatted()-- Given a fortran string, determine if the file
1689 * is suitable for unformatted form. Returns a C-style string. */
1692 inquire_unformatted (const char *string, int len)
1694 return inquire_formatted (string, len);
1698 /* inquire_access()-- Given a fortran string, determine if the file is
1699 * suitable for access. */
1702 inquire_access (const char *string, int len, int mode)
1704 char path[PATH_MAX + 1];
1706 if (string == NULL || unpack_filename (path, string, len) ||
1707 access (path, mode) < 0)
1714 /* inquire_read()-- Given a fortran string, determine if the file is
1715 * suitable for READ access. */
1718 inquire_read (const char *string, int len)
1720 return inquire_access (string, len, R_OK);
1724 /* inquire_write()-- Given a fortran string, determine if the file is
1725 * suitable for READ access. */
1728 inquire_write (const char *string, int len)
1730 return inquire_access (string, len, W_OK);
1734 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1735 * suitable for read and write access. */
1738 inquire_readwrite (const char *string, int len)
1740 return inquire_access (string, len, R_OK | W_OK);
1744 /* file_length()-- Return the file length in bytes, -1 if unknown */
1747 file_length (stream * s)
1749 gfc_offset curr, end;
1750 if (!is_seekable (s))
1755 end = sseek (s, 0, SEEK_END);
1756 sseek (s, curr, SEEK_SET);
1761 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1765 is_seekable (stream *s)
1767 /* By convention, if file_length == -1, the file is not
1769 return ((unix_stream *) s)->file_length!=-1;
1773 /* is_special()-- Return nonzero if the stream is not a regular file. */
1776 is_special (stream *s)
1778 return ((unix_stream *) s)->special_file;
1783 stream_isatty (stream *s)
1785 return isatty (((unix_stream *) s)->fd);
1789 stream_ttyname (stream *s __attribute__ ((unused)))
1792 return ttyname (((unix_stream *) s)->fd);
1799 /* How files are stored: This is an operating-system specific issue,
1800 and therefore belongs here. There are three cases to consider.
1803 Records are written as block of bytes corresponding to the record
1804 length of the file. This goes for both formatted and unformatted
1805 records. Positioning is done explicitly for each data transfer,
1806 so positioning is not much of an issue.
1808 Sequential Formatted:
1809 Records are separated by newline characters. The newline character
1810 is prohibited from appearing in a string. If it does, this will be
1811 messed up on the next read. End of file is also the end of a record.
1813 Sequential Unformatted:
1814 In this case, we are merely copying bytes to and from main storage,
1815 yet we need to keep track of varying record lengths. We adopt
1816 the solution used by f2c. Each record contains a pair of length
1819 Length of record n in bytes
1821 Length of record n in bytes
1823 Length of record n+1 in bytes
1825 Length of record n+1 in bytes
1827 The length is stored at the end of a record to allow backspacing to the
1828 previous record. Between data transfer statements, the file pointer
1829 is left pointing to the first length of the current record.
1831 ENDFILE records are never explicitly stored.