1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 /* Unix stream I/O module */
42 /* For mingw, we don't identify files by their inode number, but by a
43 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
44 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
46 #define WIN32_LEAN_AND_MEAN
50 id_from_handle (HANDLE hFile
)
52 BY_HANDLE_FILE_INFORMATION FileInformation
;
54 if (hFile
== INVALID_HANDLE_VALUE
)
57 memset (&FileInformation
, 0, sizeof(FileInformation
));
58 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
61 return ((uint64_t) FileInformation
.nFileIndexLow
)
62 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
67 id_from_path (const char *path
)
72 if (!path
|| !*path
|| access (path
, F_OK
))
75 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
76 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
78 res
= id_from_handle (hFile
);
85 id_from_fd (const int fd
)
87 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
104 /* These flags aren't defined on all targets (mingw32), so provide them
123 /* Unix and internal stream I/O module */
125 static const int BUFFER_SIZE
= 8192;
131 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
132 gfc_offset physical_offset
; /* Current physical file offset */
133 gfc_offset logical_offset
; /* Current logical file offset */
134 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
136 char *buffer
; /* Pointer to the buffer. */
137 int fd
; /* The POSIX file descriptor. */
139 int active
; /* Length of valid bytes in the buffer */
142 int ndirty
; /* Dirty bytes starting at buffer_offset */
144 int special_file
; /* =1 if the fd refers to a special file */
149 /*move_pos_offset()-- Move the record pointer right or left
150 *relative to current position */
153 move_pos_offset (stream
* st
, int pos_off
)
155 unix_stream
* str
= (unix_stream
*)st
;
158 str
->logical_offset
+= pos_off
;
160 if (str
->ndirty
> str
->logical_offset
)
162 if (str
->ndirty
+ pos_off
> 0)
163 str
->ndirty
+= pos_off
;
174 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
175 * standard descriptors, returning a non-standard descriptor. If the
176 * user specifies that system errors should go to standard output,
177 * then closes standard output, we don't want the system errors to a
178 * file that has been given file descriptor 1 or 0. We want to send
179 * the error to the invalid descriptor. */
185 int input
, output
, error
;
187 input
= output
= error
= 0;
189 /* Unix allocates the lowest descriptors first, so a loop is not
190 required, but this order is. */
191 if (fd
== STDIN_FILENO
)
196 if (fd
== STDOUT_FILENO
)
201 if (fd
== STDERR_FILENO
)
208 close (STDIN_FILENO
);
210 close (STDOUT_FILENO
);
212 close (STDERR_FILENO
);
219 is_preconnected (stream
* s
)
223 fd
= ((unix_stream
*) s
)->fd
;
224 if (fd
== STDIN_FILENO
|| fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
)
230 /* If the stream corresponds to a preconnected unit, we flush the
231 corresponding C stream. This is bugware for mixed C-Fortran codes
232 where the C code doesn't flush I/O before returning. */
234 flush_if_preconnected (stream
* s
)
238 fd
= ((unix_stream
*) s
)->fd
;
239 if (fd
== STDIN_FILENO
)
241 else if (fd
== STDOUT_FILENO
)
243 else if (fd
== STDERR_FILENO
)
248 /* get_oserror()-- Get the most recent operating system error. For
249 * unix, this is errno. */
254 return strerror (errno
);
258 /********************************************************************
259 Raw I/O functions (read, write, seek, tell, truncate, close).
261 These functions wrap the basic POSIX I/O syscalls. Any deviation in
262 semantics is a bug, except the following: write restarts in case
263 of being interrupted by a signal, and as the first argument the
264 functions take the unix_stream struct rather than an integer file
265 descriptor. Also, for POSIX read() and write() a nbyte argument larger
266 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
267 than size_t as for POSIX read/write.
268 *********************************************************************/
271 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
277 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
279 /* For read we can't do I/O in a loop like raw_write does, because
280 that will break applications that wait for interactive I/O. */
281 return read (s
->fd
, buf
, nbyte
);
285 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
287 ssize_t trans
, bytes_left
;
291 buf_st
= (char *) buf
;
293 /* We must write in a loop since some systems don't restart system
294 calls in case of a signal. */
295 while (bytes_left
> 0)
297 trans
= write (s
->fd
, buf_st
, bytes_left
);
309 return nbyte
- bytes_left
;
313 raw_seek (unix_stream
* s
, off_t offset
, int whence
)
315 return lseek (s
->fd
, offset
, whence
);
319 raw_tell (unix_stream
* s
)
321 return lseek (s
->fd
, 0, SEEK_CUR
);
325 raw_truncate (unix_stream
* s
, off_t length
)
327 #ifdef HAVE_FTRUNCATE
328 return ftruncate (s
->fd
, length
);
329 #elif defined HAVE_CHSIZE
330 return chsize (s
->fd
, length
);
332 runtime_error ("required ftruncate or chsize support not present");
338 raw_close (unix_stream
* s
)
342 if (s
->fd
!= STDOUT_FILENO
343 && s
->fd
!= STDERR_FILENO
344 && s
->fd
!= STDIN_FILENO
)
345 retval
= close (s
->fd
);
353 raw_init (unix_stream
* s
)
355 s
->st
.read
= (void *) raw_read
;
356 s
->st
.write
= (void *) raw_write
;
357 s
->st
.seek
= (void *) raw_seek
;
358 s
->st
.tell
= (void *) raw_tell
;
359 s
->st
.trunc
= (void *) raw_truncate
;
360 s
->st
.close
= (void *) raw_close
;
361 s
->st
.flush
= (void *) raw_flush
;
368 /*********************************************************************
369 Buffered I/O functions. These functions have the same semantics as the
370 raw I/O functions above, except that they are buffered in order to
371 improve performance. The buffer must be flushed when switching from
372 reading to writing and vice versa.
373 *********************************************************************/
376 buf_flush (unix_stream
* s
)
380 /* Flushing in read mode means discarding read bytes. */
386 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
387 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
390 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
392 s
->physical_offset
= s
->buffer_offset
+ writelen
;
394 /* Don't increment file_length if the file is non-seekable. */
395 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
396 s
->file_length
= s
->physical_offset
;
398 s
->ndirty
-= writelen
;
406 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
409 s
->buffer_offset
= s
->logical_offset
;
411 /* Is the data we want in the buffer? */
412 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
413 && s
->buffer_offset
<= s
->logical_offset
)
414 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
417 /* First copy the active bytes if applicable, then read the rest
418 either directly or filling the buffer. */
421 ssize_t to_read
, did_read
;
422 gfc_offset new_logical
;
425 if (s
->logical_offset
>= s
->buffer_offset
426 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
428 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
429 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
433 /* At this point we consider all bytes in the buffer discarded. */
434 to_read
= nbyte
- nread
;
435 new_logical
= s
->logical_offset
+ nread
;
436 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
437 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
439 s
->buffer_offset
= s
->physical_offset
= new_logical
;
440 if (to_read
<= BUFFER_SIZE
/2)
442 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
443 s
->physical_offset
+= did_read
;
444 s
->active
= did_read
;
445 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
446 memcpy (p
, s
->buffer
, did_read
);
450 did_read
= raw_read (s
, p
, to_read
);
451 s
->physical_offset
+= did_read
;
454 nbyte
= did_read
+ nread
;
456 s
->logical_offset
+= nbyte
;
461 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
464 s
->buffer_offset
= s
->logical_offset
;
466 /* Does the data fit into the buffer? As a special case, if the
467 buffer is empty and the request is bigger than BUFFER_SIZE/2,
468 write directly. This avoids the case where the buffer would have
469 to be flushed at every write. */
470 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
471 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
472 && s
->buffer_offset
<= s
->logical_offset
473 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
475 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
476 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
482 /* Flush, and either fill the buffer with the new data, or if
483 the request is bigger than the buffer size, write directly
484 bypassing the buffer. */
486 if (nbyte
<= BUFFER_SIZE
/2)
488 memcpy (s
->buffer
, buf
, nbyte
);
489 s
->buffer_offset
= s
->logical_offset
;
494 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
495 && lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
497 nbyte
= raw_write (s
, buf
, nbyte
);
498 s
->physical_offset
+= nbyte
;
501 s
->logical_offset
+= nbyte
;
502 /* Don't increment file_length if the file is non-seekable. */
503 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
504 s
->file_length
= s
->logical_offset
;
509 buf_seek (unix_stream
* s
, off_t offset
, int whence
)
516 offset
+= s
->logical_offset
;
519 offset
+= s
->file_length
;
529 s
->logical_offset
= offset
;
534 buf_tell (unix_stream
* s
)
536 return s
->logical_offset
;
540 buf_truncate (unix_stream
* s
, off_t length
)
544 if (buf_flush (s
) != 0)
546 r
= raw_truncate (s
, length
);
548 s
->file_length
= length
;
553 buf_close (unix_stream
* s
)
555 if (buf_flush (s
) != 0)
557 free_mem (s
->buffer
);
558 return raw_close (s
);
562 buf_init (unix_stream
* s
)
564 s
->st
.read
= (void *) buf_read
;
565 s
->st
.write
= (void *) buf_write
;
566 s
->st
.seek
= (void *) buf_seek
;
567 s
->st
.tell
= (void *) buf_tell
;
568 s
->st
.trunc
= (void *) buf_truncate
;
569 s
->st
.close
= (void *) buf_close
;
570 s
->st
.flush
= (void *) buf_flush
;
572 s
->buffer
= get_mem (BUFFER_SIZE
);
577 /*********************************************************************
578 memory stream functions - These are used for internal files
580 The idea here is that a single stream structure is created and all
581 requests must be satisfied from it. The location and size of the
582 buffer is the character variable supplied to the READ or WRITE
585 *********************************************************************/
589 mem_alloc_r (stream
* strm
, int * len
)
591 unix_stream
* s
= (unix_stream
*) strm
;
593 gfc_offset where
= s
->logical_offset
;
595 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
598 n
= s
->buffer_offset
+ s
->active
- where
;
602 s
->logical_offset
= where
+ *len
;
604 return s
->buffer
+ (where
- s
->buffer_offset
);
609 mem_alloc_w (stream
* strm
, int * len
)
611 unix_stream
* s
= (unix_stream
*) strm
;
613 gfc_offset where
= s
->logical_offset
;
617 if (where
< s
->buffer_offset
)
620 if (m
> s
->file_length
)
623 s
->logical_offset
= m
;
625 return s
->buffer
+ (where
- s
->buffer_offset
);
629 /* Stream read function for internal units. */
632 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
637 p
= mem_alloc_r (s
, &nb
);
648 /* Stream write function for internal units. This is not actually used
649 at the moment, as all internal IO is formatted and the formatted IO
650 routines use mem_alloc_w_at. */
653 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
658 p
= mem_alloc_w (s
, &nb
);
670 mem_seek (stream
* strm
, off_t offset
, int whence
)
672 unix_stream
* s
= (unix_stream
*) strm
;
678 offset
+= s
->logical_offset
;
681 offset
+= s
->file_length
;
687 /* Note that for internal array I/O it's actually possible to have a
688 negative offset, so don't check for that. */
689 if (offset
> s
->file_length
)
695 s
->logical_offset
= offset
;
697 /* Returning < 0 is the error indicator for sseek(), so return 0 if
698 offset is negative. Thus if the return value is 0, the caller
699 has to use stell() to get the real value of logical_offset. */
707 mem_tell (stream
* s
)
709 return ((unix_stream
*)s
)->logical_offset
;
714 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
715 off_t length
__attribute__ ((unused
)))
722 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
729 mem_close (unix_stream
* s
)
738 /*********************************************************************
739 Public functions -- A reimplementation of this module needs to
740 define functional equivalents of the following.
741 *********************************************************************/
743 /* empty_internal_buffer()-- Zero the buffer of Internal file */
746 empty_internal_buffer(stream
*strm
)
748 unix_stream
* s
= (unix_stream
*) strm
;
749 memset(s
->buffer
, ' ', s
->file_length
);
752 /* open_internal()-- Returns a stream structure from an internal file */
755 open_internal (char *base
, int length
, gfc_offset offset
)
759 s
= get_mem (sizeof (unix_stream
));
760 memset (s
, '\0', sizeof (unix_stream
));
763 s
->buffer_offset
= offset
;
765 s
->logical_offset
= 0;
766 s
->active
= s
->file_length
= length
;
768 s
->st
.close
= (void *) mem_close
;
769 s
->st
.seek
= (void *) mem_seek
;
770 s
->st
.tell
= (void *) mem_tell
;
771 s
->st
.trunc
= (void *) mem_truncate
;
772 s
->st
.read
= (void *) mem_read
;
773 s
->st
.write
= (void *) mem_write
;
774 s
->st
.flush
= (void *) mem_flush
;
780 /* fd_to_stream()-- Given an open file descriptor, build a stream
784 fd_to_stream (int fd
, int prot
)
789 s
= get_mem (sizeof (unix_stream
));
790 memset (s
, '\0', sizeof (unix_stream
));
793 s
->buffer_offset
= 0;
794 s
->physical_offset
= 0;
795 s
->logical_offset
= 0;
798 /* Get the current length of the file. */
800 fstat (fd
, &statbuf
);
802 if (lseek (fd
, 0, SEEK_CUR
) == (off_t
) -1)
805 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
807 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
809 if (isatty (s
->fd
) || options
.all_unbuffered
810 ||(options
.unbuffered_preconnected
&&
811 (s
->fd
== STDIN_FILENO
812 || s
->fd
== STDOUT_FILENO
813 || s
->fd
== STDERR_FILENO
)))
822 /* Given the Fortran unit number, convert it to a C file descriptor. */
825 unit_to_fd (int unit
)
830 us
= find_unit (unit
);
834 fd
= ((unix_stream
*) us
->s
)->fd
;
840 /* unpack_filename()-- Given a fortran string and a pointer to a
841 * buffer that is PATH_MAX characters, convert the fortran string to a
842 * C string in the buffer. Returns nonzero if this is not possible. */
845 unpack_filename (char *cstring
, const char *fstring
, int len
)
847 len
= fstrlen (fstring
, len
);
851 memmove (cstring
, fstring
, len
);
858 /* tempfile()-- Generate a temporary filename for a scratch file and
859 * open it. mkstemp() opens the file for reading and writing, but the
860 * library mode prevents anything that is not allowed. The descriptor
861 * is returned, which is -1 on error. The template is pointed to by
862 * opp->file, which is copied into the unit structure
863 * and freed later. */
866 tempfile (st_parameter_open
*opp
)
872 tempdir
= getenv ("GFORTRAN_TMPDIR");
874 tempdir
= getenv ("TMP");
876 tempdir
= getenv ("TEMP");
878 tempdir
= DEFAULT_TEMPDIR
;
880 template = get_mem (strlen (tempdir
) + 20);
882 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
886 fd
= mkstemp (template);
888 #else /* HAVE_MKSTEMP */
890 if (mktemp (template))
892 #if defined(HAVE_CRLF) && defined(O_BINARY)
893 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
896 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
898 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
902 #endif /* HAVE_MKSTEMP */
908 opp
->file
= template;
909 opp
->file_len
= strlen (template); /* Don't include trailing nul */
916 /* regular_file()-- Open a regular file.
917 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
918 * unless an error occurs.
919 * Returns the descriptor, which is less than zero on error. */
922 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
924 char path
[PATH_MAX
+ 1];
930 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
932 errno
= ENOENT
; /* Fake an OS error */
938 switch (flags
->action
)
948 case ACTION_READWRITE
:
949 case ACTION_UNSPECIFIED
:
954 internal_error (&opp
->common
, "regular_file(): Bad action");
957 switch (flags
->status
)
960 crflag
= O_CREAT
| O_EXCL
;
963 case STATUS_OLD
: /* open will fail if the file does not exist*/
973 crflag
= O_CREAT
| O_TRUNC
;
977 internal_error (&opp
->common
, "regular_file(): Bad status");
980 /* rwflag |= O_LARGEFILE; */
982 #if defined(HAVE_CRLF) && defined(O_BINARY)
986 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
987 fd
= open (path
, rwflag
| crflag
, mode
);
988 if (flags
->action
!= ACTION_UNSPECIFIED
)
993 flags
->action
= ACTION_READWRITE
;
996 if (errno
!= EACCES
&& errno
!= EROFS
)
999 /* retry for read-only access */
1001 fd
= open (path
, rwflag
| crflag
, mode
);
1004 flags
->action
= ACTION_READ
;
1005 return fd
; /* success */
1008 if (errno
!= EACCES
)
1009 return fd
; /* failure */
1011 /* retry for write-only access */
1013 fd
= open (path
, rwflag
| crflag
, mode
);
1016 flags
->action
= ACTION_WRITE
;
1017 return fd
; /* success */
1019 return fd
; /* failure */
1023 /* open_external()-- Open an external file, unix specific version.
1024 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1025 * Returns NULL on operating system error. */
1028 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1032 if (flags
->status
== STATUS_SCRATCH
)
1034 fd
= tempfile (opp
);
1035 if (flags
->action
== ACTION_UNSPECIFIED
)
1036 flags
->action
= ACTION_READWRITE
;
1038 #if HAVE_UNLINK_OPEN_FILE
1039 /* We can unlink scratch files now and it will go away when closed. */
1046 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1048 fd
= regular_file (opp
, flags
);
1055 switch (flags
->action
)
1065 case ACTION_READWRITE
:
1066 prot
= PROT_READ
| PROT_WRITE
;
1070 internal_error (&opp
->common
, "open_external(): Bad action");
1073 return fd_to_stream (fd
, prot
);
1077 /* input_stream()-- Return a stream pointer to the default input stream.
1078 * Called on initialization. */
1083 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1087 /* output_stream()-- Return a stream pointer to the default output stream.
1088 * Called on initialization. */
1091 output_stream (void)
1095 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1096 setmode (STDOUT_FILENO
, O_BINARY
);
1099 s
= fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1104 /* error_stream()-- Return a stream pointer to the default error stream.
1105 * Called on initialization. */
1112 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1113 setmode (STDERR_FILENO
, O_BINARY
);
1116 s
= fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1121 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1122 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1123 is big enough to completely fill a 80x25 terminal, so it shuld be
1124 OK. We use a direct write() because it is simpler and least likely
1125 to be clobbered by memory corruption. Writing an error message
1126 longer than that is an error. */
1128 #define ST_VPRINTF_SIZE 2048
1131 st_vprintf (const char *format
, va_list ap
)
1133 static char buffer
[ST_VPRINTF_SIZE
];
1137 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1138 #ifdef HAVE_VSNPRINTF
1139 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1141 written
= vsprintf(buffer
, format
, ap
);
1143 if (written
>= ST_VPRINTF_SIZE
-1)
1145 /* The error message was longer than our buffer. Ouch. Because
1146 we may have messed up things badly, report the error and
1148 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1149 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1150 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1152 #undef ERROR_MESSAGE
1157 written
= write (fd
, buffer
, written
);
1161 /* st_printf()-- printf() function for error output. This just calls
1162 st_vprintf() to do the actual work. */
1165 st_printf (const char *format
, ...)
1169 va_start (ap
, format
);
1170 written
= st_vprintf(format
, ap
);
1176 /* compare_file_filename()-- Given an open stream and a fortran string
1177 * that is a filename, figure out if the file is the same as the
1181 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1183 char path
[PATH_MAX
+ 1];
1185 #ifdef HAVE_WORKING_STAT
1193 if (unpack_filename (path
, name
, len
))
1194 return 0; /* Can't be the same */
1196 /* If the filename doesn't exist, then there is no match with the
1199 if (stat (path
, &st1
) < 0)
1202 #ifdef HAVE_WORKING_STAT
1203 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1204 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1208 /* We try to match files by a unique ID. On some filesystems (network
1209 fs and FAT), we can't generate this unique ID, and will simply compare
1211 id1
= id_from_path (path
);
1212 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1214 return (id1
== id2
);
1217 if (len
!= u
->file_len
)
1219 return (memcmp(path
, u
->file
, len
) == 0);
1224 #ifdef HAVE_WORKING_STAT
1225 # define FIND_FILE0_DECL struct stat *st
1226 # define FIND_FILE0_ARGS st
1228 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1229 # define FIND_FILE0_ARGS id, file, file_len
1232 /* find_file0()-- Recursive work function for find_file() */
1235 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1238 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1245 #ifdef HAVE_WORKING_STAT
1247 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1248 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1252 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1259 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1263 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1267 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1275 /* find_file()-- Take the current filename and see if there is a unit
1276 * that has the file already open. Returns a pointer to the unit if so. */
1279 find_file (const char *file
, gfc_charlen_type file_len
)
1281 char path
[PATH_MAX
+ 1];
1286 if (unpack_filename (path
, file
, file_len
))
1289 if (stat (path
, &st
[0]) < 0)
1292 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1293 id
= id_from_path (path
);
1298 __gthread_mutex_lock (&unit_lock
);
1300 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1304 if (! __gthread_mutex_trylock (&u
->lock
))
1306 /* assert (u->closed == 0); */
1307 __gthread_mutex_unlock (&unit_lock
);
1311 inc_waiting_locked (u
);
1313 __gthread_mutex_unlock (&unit_lock
);
1316 __gthread_mutex_lock (&u
->lock
);
1319 __gthread_mutex_lock (&unit_lock
);
1320 __gthread_mutex_unlock (&u
->lock
);
1321 if (predec_waiting_locked (u
) == 0)
1326 dec_waiting_unlocked (u
);
1332 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1336 if (u
->unit_number
> min_unit
)
1338 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1342 if (u
->unit_number
>= min_unit
)
1344 if (__gthread_mutex_trylock (&u
->lock
))
1348 __gthread_mutex_unlock (&u
->lock
);
1356 flush_all_units (void)
1361 __gthread_mutex_lock (&unit_lock
);
1364 u
= flush_all_units_1 (unit_root
, min_unit
);
1366 inc_waiting_locked (u
);
1367 __gthread_mutex_unlock (&unit_lock
);
1371 __gthread_mutex_lock (&u
->lock
);
1373 min_unit
= u
->unit_number
+ 1;
1378 __gthread_mutex_lock (&unit_lock
);
1379 __gthread_mutex_unlock (&u
->lock
);
1380 (void) predec_waiting_locked (u
);
1384 __gthread_mutex_lock (&unit_lock
);
1385 __gthread_mutex_unlock (&u
->lock
);
1386 if (predec_waiting_locked (u
) == 0)
1394 /* delete_file()-- Given a unit structure, delete the file associated
1395 * with the unit. Returns nonzero if something went wrong. */
1398 delete_file (gfc_unit
* u
)
1400 char path
[PATH_MAX
+ 1];
1402 if (unpack_filename (path
, u
->file
, u
->file_len
))
1403 { /* Shouldn't be possible */
1408 return unlink (path
);
1412 /* file_exists()-- Returns nonzero if the current filename exists on
1416 file_exists (const char *file
, gfc_charlen_type file_len
)
1418 char path
[PATH_MAX
+ 1];
1419 struct stat statbuf
;
1421 if (unpack_filename (path
, file
, file_len
))
1424 if (stat (path
, &statbuf
) < 0)
1432 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1434 /* inquire_sequential()-- Given a fortran string, determine if the
1435 * file is suitable for sequential access. Returns a C-style
1439 inquire_sequential (const char *string
, int len
)
1441 char path
[PATH_MAX
+ 1];
1442 struct stat statbuf
;
1444 if (string
== NULL
||
1445 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1448 if (S_ISREG (statbuf
.st_mode
) ||
1449 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1452 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1459 /* inquire_direct()-- Given a fortran string, determine if the file is
1460 * suitable for direct access. Returns a C-style string. */
1463 inquire_direct (const char *string
, int len
)
1465 char path
[PATH_MAX
+ 1];
1466 struct stat statbuf
;
1468 if (string
== NULL
||
1469 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1472 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1475 if (S_ISDIR (statbuf
.st_mode
) ||
1476 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1483 /* inquire_formatted()-- Given a fortran string, determine if the file
1484 * is suitable for formatted form. Returns a C-style string. */
1487 inquire_formatted (const char *string
, int len
)
1489 char path
[PATH_MAX
+ 1];
1490 struct stat statbuf
;
1492 if (string
== NULL
||
1493 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1496 if (S_ISREG (statbuf
.st_mode
) ||
1497 S_ISBLK (statbuf
.st_mode
) ||
1498 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1501 if (S_ISDIR (statbuf
.st_mode
))
1508 /* inquire_unformatted()-- Given a fortran string, determine if the file
1509 * is suitable for unformatted form. Returns a C-style string. */
1512 inquire_unformatted (const char *string
, int len
)
1514 return inquire_formatted (string
, len
);
1528 /* Fallback implementation of access() on systems that don't have it.
1529 Only modes R_OK and W_OK are used in this file. */
1532 fallback_access (const char *path
, int mode
)
1534 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
1537 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
1544 #define access fallback_access
1548 /* inquire_access()-- Given a fortran string, determine if the file is
1549 * suitable for access. */
1552 inquire_access (const char *string
, int len
, int mode
)
1554 char path
[PATH_MAX
+ 1];
1556 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1557 access (path
, mode
) < 0)
1564 /* inquire_read()-- Given a fortran string, determine if the file is
1565 * suitable for READ access. */
1568 inquire_read (const char *string
, int len
)
1570 return inquire_access (string
, len
, R_OK
);
1574 /* inquire_write()-- Given a fortran string, determine if the file is
1575 * suitable for READ access. */
1578 inquire_write (const char *string
, int len
)
1580 return inquire_access (string
, len
, W_OK
);
1584 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1585 * suitable for read and write access. */
1588 inquire_readwrite (const char *string
, int len
)
1590 return inquire_access (string
, len
, R_OK
| W_OK
);
1594 /* file_length()-- Return the file length in bytes, -1 if unknown */
1597 file_length (stream
* s
)
1600 if (!is_seekable (s
))
1605 end
= sseek (s
, 0, SEEK_END
);
1606 sseek (s
, curr
, SEEK_SET
);
1611 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1615 is_seekable (stream
*s
)
1617 /* By convention, if file_length == -1, the file is not
1619 return ((unix_stream
*) s
)->file_length
!=-1;
1623 /* is_special()-- Return nonzero if the stream is not a regular file. */
1626 is_special (stream
*s
)
1628 return ((unix_stream
*) s
)->special_file
;
1633 stream_isatty (stream
*s
)
1635 return isatty (((unix_stream
*) s
)->fd
);
1639 stream_ttyname (stream
*s
__attribute__ ((unused
)))
1642 return ttyname (((unix_stream
*) s
)->fd
);
1649 /* How files are stored: This is an operating-system specific issue,
1650 and therefore belongs here. There are three cases to consider.
1653 Records are written as block of bytes corresponding to the record
1654 length of the file. This goes for both formatted and unformatted
1655 records. Positioning is done explicitly for each data transfer,
1656 so positioning is not much of an issue.
1658 Sequential Formatted:
1659 Records are separated by newline characters. The newline character
1660 is prohibited from appearing in a string. If it does, this will be
1661 messed up on the next read. End of file is also the end of a record.
1663 Sequential Unformatted:
1664 In this case, we are merely copying bytes to and from main storage,
1665 yet we need to keep track of varying record lengths. We adopt
1666 the solution used by f2c. Each record contains a pair of length
1669 Length of record n in bytes
1671 Length of record n in bytes
1673 Length of record n+1 in bytes
1675 Length of record n+1 in bytes
1677 The length is stored at the end of a record to allow backspacing to the
1678 previous record. Between data transfer statements, the file pointer
1679 is left pointing to the first length of the current record.
1681 ENDFILE records are never explicitly stored.