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;
138 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
139 * standard descriptors, returning a non-standard descriptor. If the
140 * user specifies that system errors should go to standard output,
141 * then closes standard output, we don't want the system errors to a
142 * file that has been given file descriptor 1 or 0. We want to send
143 * the error to the invalid descriptor. */
149 int input, output, error;
151 input = output = error = 0;
153 /* Unix allocates the lowest descriptors first, so a loop is not
154 required, but this order is. */
155 if (fd == STDIN_FILENO)
160 if (fd == STDOUT_FILENO)
165 if (fd == STDERR_FILENO)
172 close (STDIN_FILENO);
174 close (STDOUT_FILENO);
176 close (STDERR_FILENO);
183 /* If the stream corresponds to a preconnected unit, we flush the
184 corresponding C stream. This is bugware for mixed C-Fortran codes
185 where the C code doesn't flush I/O before returning. */
187 flush_if_preconnected (stream * s)
191 fd = ((unix_stream *) s)->fd;
192 if (fd == STDIN_FILENO)
194 else if (fd == STDOUT_FILENO)
196 else if (fd == STDERR_FILENO)
201 /* get_oserror()-- Get the most recent operating system error. For
202 * unix, this is errno. */
207 return strerror (errno);
211 /********************************************************************
212 Raw I/O functions (read, write, seek, tell, truncate, close).
214 These functions wrap the basic POSIX I/O syscalls. Any deviation in
215 semantics is a bug, except the following: write restarts in case
216 of being interrupted by a signal, and as the first argument the
217 functions take the unix_stream struct rather than an integer file
218 descriptor. Also, for POSIX read() and write() a nbyte argument larger
219 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
220 than size_t as for POSIX read/write.
221 *********************************************************************/
224 raw_flush (unix_stream * s __attribute__ ((unused)))
230 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
232 /* For read we can't do I/O in a loop like raw_write does, because
233 that will break applications that wait for interactive I/O. */
234 return read (s->fd, buf, nbyte);
238 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
240 ssize_t trans, bytes_left;
244 buf_st = (char *) buf;
246 /* We must write in a loop since some systems don't restart system
247 calls in case of a signal. */
248 while (bytes_left > 0)
250 trans = write (s->fd, buf_st, bytes_left);
262 return nbyte - bytes_left;
266 raw_seek (unix_stream * s, gfc_offset offset, int whence)
268 return lseek (s->fd, offset, whence);
272 raw_tell (unix_stream * s)
274 return lseek (s->fd, 0, SEEK_CUR);
278 raw_truncate (unix_stream * s, gfc_offset length)
289 h = (HANDLE) _get_osfhandle (s->fd);
290 if (h == INVALID_HANDLE_VALUE)
295 cur = lseek (s->fd, 0, SEEK_CUR);
298 if (lseek (s->fd, length, SEEK_SET) == -1)
300 if (!SetEndOfFile (h))
305 if (lseek (s->fd, cur, SEEK_SET) == -1)
309 lseek (s->fd, cur, SEEK_SET);
311 #elif defined HAVE_FTRUNCATE
312 return ftruncate (s->fd, length);
313 #elif defined HAVE_CHSIZE
314 return chsize (s->fd, length);
316 runtime_error ("required ftruncate or chsize support not present");
322 raw_close (unix_stream * s)
326 if (s->fd != STDOUT_FILENO
327 && s->fd != STDERR_FILENO
328 && s->fd != STDIN_FILENO)
329 retval = close (s->fd);
337 raw_init (unix_stream * s)
339 s->st.read = (void *) raw_read;
340 s->st.write = (void *) raw_write;
341 s->st.seek = (void *) raw_seek;
342 s->st.tell = (void *) raw_tell;
343 s->st.trunc = (void *) raw_truncate;
344 s->st.close = (void *) raw_close;
345 s->st.flush = (void *) raw_flush;
352 /*********************************************************************
353 Buffered I/O functions. These functions have the same semantics as the
354 raw I/O functions above, except that they are buffered in order to
355 improve performance. The buffer must be flushed when switching from
356 reading to writing and vice versa.
357 *********************************************************************/
360 buf_flush (unix_stream * s)
364 /* Flushing in read mode means discarding read bytes. */
370 if (s->file_length != -1 && s->physical_offset != s->buffer_offset
371 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
374 writelen = raw_write (s, s->buffer, s->ndirty);
376 s->physical_offset = s->buffer_offset + writelen;
378 /* Don't increment file_length if the file is non-seekable. */
379 if (s->file_length != -1 && s->physical_offset > s->file_length)
380 s->file_length = s->physical_offset;
382 s->ndirty -= writelen;
394 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
397 s->buffer_offset = s->logical_offset;
399 /* Is the data we want in the buffer? */
400 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
401 && s->buffer_offset <= s->logical_offset)
402 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
405 /* First copy the active bytes if applicable, then read the rest
406 either directly or filling the buffer. */
409 ssize_t to_read, did_read;
410 gfc_offset new_logical;
413 if (s->logical_offset >= s->buffer_offset
414 && s->buffer_offset + s->active >= s->logical_offset)
416 nread = s->active - (s->logical_offset - s->buffer_offset);
417 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
421 /* At this point we consider all bytes in the buffer discarded. */
422 to_read = nbyte - nread;
423 new_logical = s->logical_offset + nread;
424 if (s->file_length != -1 && s->physical_offset != new_logical
425 && lseek (s->fd, new_logical, SEEK_SET) < 0)
427 s->buffer_offset = s->physical_offset = new_logical;
428 if (to_read <= BUFFER_SIZE/2)
430 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
431 s->physical_offset += did_read;
432 s->active = did_read;
433 did_read = (did_read > to_read) ? to_read : did_read;
434 memcpy (p, s->buffer, did_read);
438 did_read = raw_read (s, p, to_read);
439 s->physical_offset += did_read;
442 nbyte = did_read + nread;
444 s->logical_offset += nbyte;
449 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
452 s->buffer_offset = s->logical_offset;
454 /* Does the data fit into the buffer? As a special case, if the
455 buffer is empty and the request is bigger than BUFFER_SIZE/2,
456 write directly. This avoids the case where the buffer would have
457 to be flushed at every write. */
458 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
459 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
460 && s->buffer_offset <= s->logical_offset
461 && s->buffer_offset + s->ndirty >= s->logical_offset)
463 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
464 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
470 /* Flush, and either fill the buffer with the new data, or if
471 the request is bigger than the buffer size, write directly
472 bypassing the buffer. */
474 if (nbyte <= BUFFER_SIZE/2)
476 memcpy (s->buffer, buf, nbyte);
477 s->buffer_offset = s->logical_offset;
482 if (s->file_length != -1 && s->physical_offset != s->logical_offset)
484 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
486 s->physical_offset = s->logical_offset;
489 nbyte = raw_write (s, buf, nbyte);
490 s->physical_offset += nbyte;
493 s->logical_offset += nbyte;
494 /* Don't increment file_length if the file is non-seekable. */
495 if (s->file_length != -1 && s->logical_offset > s->file_length)
496 s->file_length = s->logical_offset;
501 buf_seek (unix_stream * s, gfc_offset offset, int whence)
508 offset += s->logical_offset;
511 offset += s->file_length;
521 s->logical_offset = offset;
526 buf_tell (unix_stream * s)
528 return s->logical_offset;
532 buf_truncate (unix_stream * s, gfc_offset length)
536 if (buf_flush (s) != 0)
538 r = raw_truncate (s, length);
540 s->file_length = length;
545 buf_close (unix_stream * s)
547 if (buf_flush (s) != 0)
550 return raw_close (s);
554 buf_init (unix_stream * s)
556 s->st.read = (void *) buf_read;
557 s->st.write = (void *) buf_write;
558 s->st.seek = (void *) buf_seek;
559 s->st.tell = (void *) buf_tell;
560 s->st.trunc = (void *) buf_truncate;
561 s->st.close = (void *) buf_close;
562 s->st.flush = (void *) buf_flush;
564 s->buffer = get_mem (BUFFER_SIZE);
569 /*********************************************************************
570 memory stream functions - These are used for internal files
572 The idea here is that a single stream structure is created and all
573 requests must be satisfied from it. The location and size of the
574 buffer is the character variable supplied to the READ or WRITE
577 *********************************************************************/
580 mem_alloc_r (stream * strm, int * len)
582 unix_stream * s = (unix_stream *) strm;
584 gfc_offset where = s->logical_offset;
586 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
589 n = s->buffer_offset + s->active - where;
593 s->logical_offset = where + *len;
595 return s->buffer + (where - s->buffer_offset);
600 mem_alloc_r4 (stream * strm, int * len)
602 unix_stream * s = (unix_stream *) strm;
604 gfc_offset where = s->logical_offset;
606 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
609 n = s->buffer_offset + s->active - where;
613 s->logical_offset = where + *len;
615 return s->buffer + (where - s->buffer_offset) * 4;
620 mem_alloc_w (stream * strm, int * len)
622 unix_stream * s = (unix_stream *) strm;
624 gfc_offset where = s->logical_offset;
628 if (where < s->buffer_offset)
631 if (m > s->file_length)
634 s->logical_offset = m;
636 return s->buffer + (where - s->buffer_offset);
641 mem_alloc_w4 (stream * strm, int * len)
643 unix_stream * s = (unix_stream *) strm;
645 gfc_offset where = s->logical_offset;
646 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
650 if (where < s->buffer_offset)
653 if (m > s->file_length)
656 s->logical_offset = m;
657 return &result[where - s->buffer_offset];
661 /* Stream read function for character(kine=1) internal units. */
664 mem_read (stream * s, void * buf, ssize_t nbytes)
669 p = mem_alloc_r (s, &nb);
680 /* Stream read function for chracter(kind=4) internal units. */
683 mem_read4 (stream * s, void * buf, ssize_t nbytes)
688 p = mem_alloc_r (s, &nb);
699 /* Stream write function for character(kind=1) internal units. */
702 mem_write (stream * s, const void * buf, ssize_t nbytes)
707 p = mem_alloc_w (s, &nb);
718 /* Stream write function for character(kind=4) internal units. */
721 mem_write4 (stream * s, const void * buf, ssize_t nwords)
726 p = mem_alloc_w4 (s, &nw);
730 *p++ = (gfc_char4_t) *((char *) buf);
739 mem_seek (stream * strm, gfc_offset offset, int whence)
741 unix_stream * s = (unix_stream *) strm;
747 offset += s->logical_offset;
750 offset += s->file_length;
756 /* Note that for internal array I/O it's actually possible to have a
757 negative offset, so don't check for that. */
758 if (offset > s->file_length)
764 s->logical_offset = offset;
766 /* Returning < 0 is the error indicator for sseek(), so return 0 if
767 offset is negative. Thus if the return value is 0, the caller
768 has to use stell() to get the real value of logical_offset. */
776 mem_tell (stream * s)
778 return ((unix_stream *)s)->logical_offset;
783 mem_truncate (unix_stream * s __attribute__ ((unused)),
784 gfc_offset length __attribute__ ((unused)))
791 mem_flush (unix_stream * s __attribute__ ((unused)))
798 mem_close (unix_stream * s)
807 /*********************************************************************
808 Public functions -- A reimplementation of this module needs to
809 define functional equivalents of the following.
810 *********************************************************************/
812 /* empty_internal_buffer()-- Zero the buffer of Internal file */
815 empty_internal_buffer(stream *strm)
817 unix_stream * s = (unix_stream *) strm;
818 memset(s->buffer, ' ', s->file_length);
821 /* open_internal()-- Returns a stream structure from a character(kind=1)
825 open_internal (char *base, int length, gfc_offset offset)
829 s = get_mem (sizeof (unix_stream));
830 memset (s, '\0', sizeof (unix_stream));
833 s->buffer_offset = offset;
835 s->logical_offset = 0;
836 s->active = s->file_length = length;
838 s->st.close = (void *) mem_close;
839 s->st.seek = (void *) mem_seek;
840 s->st.tell = (void *) mem_tell;
841 s->st.trunc = (void *) mem_truncate;
842 s->st.read = (void *) mem_read;
843 s->st.write = (void *) mem_write;
844 s->st.flush = (void *) mem_flush;
849 /* open_internal4()-- Returns a stream structure from a character(kind=4)
853 open_internal4 (char *base, int length, gfc_offset offset)
857 s = get_mem (sizeof (unix_stream));
858 memset (s, '\0', sizeof (unix_stream));
861 s->buffer_offset = offset;
863 s->logical_offset = 0;
864 s->active = s->file_length = length;
866 s->st.close = (void *) mem_close;
867 s->st.seek = (void *) mem_seek;
868 s->st.tell = (void *) mem_tell;
869 s->st.trunc = (void *) mem_truncate;
870 s->st.read = (void *) mem_read4;
871 s->st.write = (void *) mem_write4;
872 s->st.flush = (void *) mem_flush;
878 /* fd_to_stream()-- Given an open file descriptor, build a stream
882 fd_to_stream (int fd, int prot)
887 s = get_mem (sizeof (unix_stream));
888 memset (s, '\0', sizeof (unix_stream));
891 s->buffer_offset = 0;
892 s->physical_offset = 0;
893 s->logical_offset = 0;
896 /* Get the current length of the file. */
898 fstat (fd, &statbuf);
900 if (lseek (fd, 0, SEEK_CUR) == (gfc_offset) -1)
903 s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
905 s->special_file = !S_ISREG (statbuf.st_mode);
907 if (isatty (s->fd) || options.all_unbuffered
908 ||(options.unbuffered_preconnected &&
909 (s->fd == STDIN_FILENO
910 || s->fd == STDOUT_FILENO
911 || s->fd == STDERR_FILENO)))
920 /* Given the Fortran unit number, convert it to a C file descriptor. */
923 unit_to_fd (int unit)
928 us = find_unit (unit);
932 fd = ((unix_stream *) us->s)->fd;
938 /* unpack_filename()-- Given a fortran string and a pointer to a
939 * buffer that is PATH_MAX characters, convert the fortran string to a
940 * C string in the buffer. Returns nonzero if this is not possible. */
943 unpack_filename (char *cstring, const char *fstring, int len)
945 len = fstrlen (fstring, len);
949 memmove (cstring, fstring, len);
956 /* tempfile()-- Generate a temporary filename for a scratch file and
957 * open it. mkstemp() opens the file for reading and writing, but the
958 * library mode prevents anything that is not allowed. The descriptor
959 * is returned, which is -1 on error. The template is pointed to by
960 * opp->file, which is copied into the unit structure
961 * and freed later. */
964 tempfile (st_parameter_open *opp)
968 const char *slash = "/";
971 tempdir = getenv ("GFORTRAN_TMPDIR");
975 char buffer[MAX_PATH + 1];
977 ret = GetTempPath (MAX_PATH, buffer);
978 /* If we are not able to get a temp-directory, we use
979 current directory. */
980 if (ret > MAX_PATH || !ret)
984 tempdir = strdup (buffer);
988 tempdir = getenv ("TMP");
990 tempdir = getenv ("TEMP");
992 tempdir = DEFAULT_TEMPDIR;
994 /* Check for special case that tempdir contains slash
995 or backslash at end. */
996 if (*tempdir == 0 || tempdir[strlen (tempdir) - 1] == '/'
998 || tempdir[strlen (tempdir) - 1] == '\\'
1003 template = get_mem (strlen (tempdir) + 20);
1006 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
1008 fd = mkstemp (template);
1010 #else /* HAVE_MKSTEMP */
1014 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
1015 if (!mktemp (template))
1017 #if defined(HAVE_CRLF) && defined(O_BINARY)
1018 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1019 S_IREAD | S_IWRITE);
1021 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1024 while (fd == -1 && errno == EEXIST);
1025 #endif /* HAVE_MKSTEMP */
1031 opp->file = template;
1032 opp->file_len = strlen (template); /* Don't include trailing nul */
1039 /* regular_file()-- Open a regular file.
1040 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1041 * unless an error occurs.
1042 * Returns the descriptor, which is less than zero on error. */
1045 regular_file (st_parameter_open *opp, unit_flags *flags)
1047 char path[PATH_MAX + 1];
1053 if (unpack_filename (path, opp->file, opp->file_len))
1055 errno = ENOENT; /* Fake an OS error */
1060 if (opp->file_len == 7)
1062 if (strncmp (path, "CONOUT$", 7) == 0
1063 || strncmp (path, "CONERR$", 7) == 0)
1065 fd = open ("/dev/conout", O_WRONLY);
1066 flags->action = ACTION_WRITE;
1071 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1073 fd = open ("/dev/conin", O_RDONLY);
1074 flags->action = ACTION_READ;
1081 if (opp->file_len == 7)
1083 if (strncmp (path, "CONOUT$", 7) == 0
1084 || strncmp (path, "CONERR$", 7) == 0)
1086 fd = open ("CONOUT$", O_WRONLY);
1087 flags->action = ACTION_WRITE;
1092 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1094 fd = open ("CONIN$", O_RDONLY);
1095 flags->action = ACTION_READ;
1102 switch (flags->action)
1112 case ACTION_READWRITE:
1113 case ACTION_UNSPECIFIED:
1118 internal_error (&opp->common, "regular_file(): Bad action");
1121 switch (flags->status)
1124 crflag = O_CREAT | O_EXCL;
1127 case STATUS_OLD: /* open will fail if the file does not exist*/
1131 case STATUS_UNKNOWN:
1132 case STATUS_SCRATCH:
1136 case STATUS_REPLACE:
1137 crflag = O_CREAT | O_TRUNC;
1141 internal_error (&opp->common, "regular_file(): Bad status");
1144 /* rwflag |= O_LARGEFILE; */
1146 #if defined(HAVE_CRLF) && defined(O_BINARY)
1150 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1151 fd = open (path, rwflag | crflag, mode);
1152 if (flags->action != ACTION_UNSPECIFIED)
1157 flags->action = ACTION_READWRITE;
1160 if (errno != EACCES && errno != EROFS)
1163 /* retry for read-only access */
1165 fd = open (path, rwflag | crflag, mode);
1168 flags->action = ACTION_READ;
1169 return fd; /* success */
1172 if (errno != EACCES)
1173 return fd; /* failure */
1175 /* retry for write-only access */
1177 fd = open (path, rwflag | crflag, mode);
1180 flags->action = ACTION_WRITE;
1181 return fd; /* success */
1183 return fd; /* failure */
1187 /* open_external()-- Open an external file, unix specific version.
1188 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1189 * Returns NULL on operating system error. */
1192 open_external (st_parameter_open *opp, unit_flags *flags)
1196 if (flags->status == STATUS_SCRATCH)
1198 fd = tempfile (opp);
1199 if (flags->action == ACTION_UNSPECIFIED)
1200 flags->action = ACTION_READWRITE;
1202 #if HAVE_UNLINK_OPEN_FILE
1203 /* We can unlink scratch files now and it will go away when closed. */
1210 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1212 fd = regular_file (opp, flags);
1219 switch (flags->action)
1229 case ACTION_READWRITE:
1230 prot = PROT_READ | PROT_WRITE;
1234 internal_error (&opp->common, "open_external(): Bad action");
1237 return fd_to_stream (fd, prot);
1241 /* input_stream()-- Return a stream pointer to the default input stream.
1242 * Called on initialization. */
1247 return fd_to_stream (STDIN_FILENO, PROT_READ);
1251 /* output_stream()-- Return a stream pointer to the default output stream.
1252 * Called on initialization. */
1255 output_stream (void)
1259 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1260 setmode (STDOUT_FILENO, O_BINARY);
1263 s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1268 /* error_stream()-- Return a stream pointer to the default error stream.
1269 * Called on initialization. */
1276 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1277 setmode (STDERR_FILENO, O_BINARY);
1280 s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1285 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1286 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1287 is big enough to completely fill a 80x25 terminal, so it shuld be
1288 OK. We use a direct write() because it is simpler and least likely
1289 to be clobbered by memory corruption. Writing an error message
1290 longer than that is an error. */
1292 #define ST_VPRINTF_SIZE 2048
1295 st_vprintf (const char *format, va_list ap)
1297 static char buffer[ST_VPRINTF_SIZE];
1301 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1302 #ifdef HAVE_VSNPRINTF
1303 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1305 written = vsprintf(buffer, format, ap);
1307 if (written >= ST_VPRINTF_SIZE-1)
1309 /* The error message was longer than our buffer. Ouch. Because
1310 we may have messed up things badly, report the error and
1312 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1313 write (fd, buffer, ST_VPRINTF_SIZE-1);
1314 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1316 #undef ERROR_MESSAGE
1321 written = write (fd, buffer, written);
1325 /* st_printf()-- printf() function for error output. This just calls
1326 st_vprintf() to do the actual work. */
1329 st_printf (const char *format, ...)
1333 va_start (ap, format);
1334 written = st_vprintf(format, ap);
1340 /* compare_file_filename()-- Given an open stream and a fortran string
1341 * that is a filename, figure out if the file is the same as the
1345 compare_file_filename (gfc_unit *u, const char *name, int len)
1347 char path[PATH_MAX + 1];
1349 #ifdef HAVE_WORKING_STAT
1357 if (unpack_filename (path, name, len))
1358 return 0; /* Can't be the same */
1360 /* If the filename doesn't exist, then there is no match with the
1363 if (stat (path, &st1) < 0)
1366 #ifdef HAVE_WORKING_STAT
1367 fstat (((unix_stream *) (u->s))->fd, &st2);
1368 return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1372 /* We try to match files by a unique ID. On some filesystems (network
1373 fs and FAT), we can't generate this unique ID, and will simply compare
1375 id1 = id_from_path (path);
1376 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1378 return (id1 == id2);
1381 if (len != u->file_len)
1383 return (memcmp(path, u->file, len) == 0);
1388 #ifdef HAVE_WORKING_STAT
1389 # define FIND_FILE0_DECL gfstat_t *st
1390 # define FIND_FILE0_ARGS st
1392 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1393 # define FIND_FILE0_ARGS id, file, file_len
1396 /* find_file0()-- Recursive work function for find_file() */
1399 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1402 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1409 #ifdef HAVE_WORKING_STAT
1411 && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1412 st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1416 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1423 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1427 v = find_file0 (u->left, FIND_FILE0_ARGS);
1431 v = find_file0 (u->right, FIND_FILE0_ARGS);
1439 /* find_file()-- Take the current filename and see if there is a unit
1440 * that has the file already open. Returns a pointer to the unit if so. */
1443 find_file (const char *file, gfc_charlen_type file_len)
1445 char path[PATH_MAX + 1];
1448 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1452 if (unpack_filename (path, file, file_len))
1455 if (stat (path, &st[0]) < 0)
1458 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1459 id = id_from_path (path);
1462 __gthread_mutex_lock (&unit_lock);
1464 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1468 if (! __gthread_mutex_trylock (&u->lock))
1470 /* assert (u->closed == 0); */
1471 __gthread_mutex_unlock (&unit_lock);
1475 inc_waiting_locked (u);
1477 __gthread_mutex_unlock (&unit_lock);
1480 __gthread_mutex_lock (&u->lock);
1483 __gthread_mutex_lock (&unit_lock);
1484 __gthread_mutex_unlock (&u->lock);
1485 if (predec_waiting_locked (u) == 0)
1490 dec_waiting_unlocked (u);
1496 flush_all_units_1 (gfc_unit *u, int min_unit)
1500 if (u->unit_number > min_unit)
1502 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1506 if (u->unit_number >= min_unit)
1508 if (__gthread_mutex_trylock (&u->lock))
1512 __gthread_mutex_unlock (&u->lock);
1520 flush_all_units (void)
1525 __gthread_mutex_lock (&unit_lock);
1528 u = flush_all_units_1 (unit_root, min_unit);
1530 inc_waiting_locked (u);
1531 __gthread_mutex_unlock (&unit_lock);
1535 __gthread_mutex_lock (&u->lock);
1537 min_unit = u->unit_number + 1;
1542 __gthread_mutex_lock (&unit_lock);
1543 __gthread_mutex_unlock (&u->lock);
1544 (void) predec_waiting_locked (u);
1548 __gthread_mutex_lock (&unit_lock);
1549 __gthread_mutex_unlock (&u->lock);
1550 if (predec_waiting_locked (u) == 0)
1558 /* delete_file()-- Given a unit structure, delete the file associated
1559 * with the unit. Returns nonzero if something went wrong. */
1562 delete_file (gfc_unit * u)
1564 char path[PATH_MAX + 1];
1566 if (unpack_filename (path, u->file, u->file_len))
1567 { /* Shouldn't be possible */
1572 return unlink (path);
1576 /* file_exists()-- Returns nonzero if the current filename exists on
1580 file_exists (const char *file, gfc_charlen_type file_len)
1582 char path[PATH_MAX + 1];
1585 if (unpack_filename (path, file, file_len))
1588 if (stat (path, &statbuf) < 0)
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);
1708 /* Fallback implementation of access() on systems that don't have it.
1709 Only modes R_OK and W_OK are used in this file. */
1712 fallback_access (const char *path, int mode)
1714 if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1717 if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1724 #define access fallback_access
1728 /* inquire_access()-- Given a fortran string, determine if the file is
1729 * suitable for access. */
1732 inquire_access (const char *string, int len, int mode)
1734 char path[PATH_MAX + 1];
1736 if (string == NULL || unpack_filename (path, string, len) ||
1737 access (path, mode) < 0)
1744 /* inquire_read()-- Given a fortran string, determine if the file is
1745 * suitable for READ access. */
1748 inquire_read (const char *string, int len)
1750 return inquire_access (string, len, R_OK);
1754 /* inquire_write()-- Given a fortran string, determine if the file is
1755 * suitable for READ access. */
1758 inquire_write (const char *string, int len)
1760 return inquire_access (string, len, W_OK);
1764 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1765 * suitable for read and write access. */
1768 inquire_readwrite (const char *string, int len)
1770 return inquire_access (string, len, R_OK | W_OK);
1774 /* file_length()-- Return the file length in bytes, -1 if unknown */
1777 file_length (stream * s)
1779 gfc_offset curr, end;
1780 if (!is_seekable (s))
1785 end = sseek (s, 0, SEEK_END);
1786 sseek (s, curr, SEEK_SET);
1791 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1795 is_seekable (stream *s)
1797 /* By convention, if file_length == -1, the file is not
1799 return ((unix_stream *) s)->file_length!=-1;
1803 /* is_special()-- Return nonzero if the stream is not a regular file. */
1806 is_special (stream *s)
1808 return ((unix_stream *) s)->special_file;
1813 stream_isatty (stream *s)
1815 return isatty (((unix_stream *) s)->fd);
1819 stream_ttyname (stream *s __attribute__ ((unused)))
1822 return ttyname (((unix_stream *) s)->fd);
1829 /* How files are stored: This is an operating-system specific issue,
1830 and therefore belongs here. There are three cases to consider.
1833 Records are written as block of bytes corresponding to the record
1834 length of the file. This goes for both formatted and unformatted
1835 records. Positioning is done explicitly for each data transfer,
1836 so positioning is not much of an issue.
1838 Sequential Formatted:
1839 Records are separated by newline characters. The newline character
1840 is prohibited from appearing in a string. If it does, this will be
1841 messed up on the next read. End of file is also the end of a record.
1843 Sequential Unformatted:
1844 In this case, we are merely copying bytes to and from main storage,
1845 yet we need to keep track of varying record lengths. We adopt
1846 the solution used by f2c. Each record contains a pair of length
1849 Length of record n in bytes
1851 Length of record n in bytes
1853 Length of record n+1 in bytes
1855 Length of record n+1 in bytes
1857 The length is stored at the end of a record to allow backspacing to the
1858 previous record. Between data transfer statements, the file pointer
1859 is left pointing to the first length of the current record.
1861 ENDFILE records are never explicitly stored.