1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 /* Unix stream I/O module */
43 /* For mingw, we don't identify files by their inode number, but by a
44 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
45 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
47 #define WIN32_LEAN_AND_MEAN
50 #define lseek _lseeki64
53 id_from_handle (HANDLE hFile
)
55 BY_HANDLE_FILE_INFORMATION FileInformation
;
57 if (hFile
== INVALID_HANDLE_VALUE
)
60 memset (&FileInformation
, 0, sizeof(FileInformation
));
61 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
64 return ((uint64_t) FileInformation
.nFileIndexLow
)
65 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
70 id_from_path (const char *path
)
75 if (!path
|| !*path
|| access (path
, F_OK
))
78 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
79 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
81 res
= id_from_handle (hFile
);
88 id_from_fd (const int fd
)
90 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
107 /* These flags aren't defined on all targets (mingw32), so provide them
126 /* Unix and internal stream I/O module */
128 static const int BUFFER_SIZE
= 8192;
134 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
135 gfc_offset physical_offset
; /* Current physical file offset */
136 gfc_offset logical_offset
; /* Current logical file offset */
137 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
139 char *buffer
; /* Pointer to the buffer. */
140 int fd
; /* The POSIX file descriptor. */
142 int active
; /* Length of valid bytes in the buffer */
145 int ndirty
; /* Dirty bytes starting at buffer_offset */
147 int special_file
; /* =1 if the fd refers to a special file */
152 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
153 * standard descriptors, returning a non-standard descriptor. If the
154 * user specifies that system errors should go to standard output,
155 * then closes standard output, we don't want the system errors to a
156 * file that has been given file descriptor 1 or 0. We want to send
157 * the error to the invalid descriptor. */
163 int input
, output
, error
;
165 input
= output
= error
= 0;
167 /* Unix allocates the lowest descriptors first, so a loop is not
168 required, but this order is. */
169 if (fd
== STDIN_FILENO
)
174 if (fd
== STDOUT_FILENO
)
179 if (fd
== STDERR_FILENO
)
186 close (STDIN_FILENO
);
188 close (STDOUT_FILENO
);
190 close (STDERR_FILENO
);
197 /* If the stream corresponds to a preconnected unit, we flush the
198 corresponding C stream. This is bugware for mixed C-Fortran codes
199 where the C code doesn't flush I/O before returning. */
201 flush_if_preconnected (stream
* s
)
205 fd
= ((unix_stream
*) s
)->fd
;
206 if (fd
== STDIN_FILENO
)
208 else if (fd
== STDOUT_FILENO
)
210 else if (fd
== STDERR_FILENO
)
215 /* get_oserror()-- Get the most recent operating system error. For
216 * unix, this is errno. */
221 return strerror (errno
);
225 /********************************************************************
226 Raw I/O functions (read, write, seek, tell, truncate, close).
228 These functions wrap the basic POSIX I/O syscalls. Any deviation in
229 semantics is a bug, except the following: write restarts in case
230 of being interrupted by a signal, and as the first argument the
231 functions take the unix_stream struct rather than an integer file
232 descriptor. Also, for POSIX read() and write() a nbyte argument larger
233 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
234 than size_t as for POSIX read/write.
235 *********************************************************************/
238 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
244 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
246 /* For read we can't do I/O in a loop like raw_write does, because
247 that will break applications that wait for interactive I/O. */
248 return read (s
->fd
, buf
, nbyte
);
252 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
254 ssize_t trans
, bytes_left
;
258 buf_st
= (char *) buf
;
260 /* We must write in a loop since some systems don't restart system
261 calls in case of a signal. */
262 while (bytes_left
> 0)
264 trans
= write (s
->fd
, buf_st
, bytes_left
);
276 return nbyte
- bytes_left
;
280 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
282 return lseek (s
->fd
, offset
, whence
);
286 raw_tell (unix_stream
* s
)
288 return lseek (s
->fd
, 0, SEEK_CUR
);
292 raw_truncate (unix_stream
* s
, gfc_offset length
)
303 h
= _get_osfhandle (s
->fd
);
304 if (h
== INVALID_HANDLE_VALUE
)
309 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
312 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
314 if (!SetEndOfFile (h
))
319 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
323 lseek (s
->fd
, cur
, SEEK_SET
);
325 #elif defined HAVE_FTRUNCATE
326 return ftruncate (s
->fd
, length
);
327 #elif defined HAVE_CHSIZE
328 return chsize (s
->fd
, length
);
330 runtime_error ("required ftruncate or chsize support not present");
336 raw_close (unix_stream
* s
)
340 if (s
->fd
!= STDOUT_FILENO
341 && s
->fd
!= STDERR_FILENO
342 && s
->fd
!= STDIN_FILENO
)
343 retval
= close (s
->fd
);
351 raw_init (unix_stream
* s
)
353 s
->st
.read
= (void *) raw_read
;
354 s
->st
.write
= (void *) raw_write
;
355 s
->st
.seek
= (void *) raw_seek
;
356 s
->st
.tell
= (void *) raw_tell
;
357 s
->st
.trunc
= (void *) raw_truncate
;
358 s
->st
.close
= (void *) raw_close
;
359 s
->st
.flush
= (void *) raw_flush
;
366 /*********************************************************************
367 Buffered I/O functions. These functions have the same semantics as the
368 raw I/O functions above, except that they are buffered in order to
369 improve performance. The buffer must be flushed when switching from
370 reading to writing and vice versa.
371 *********************************************************************/
374 buf_flush (unix_stream
* s
)
378 /* Flushing in read mode means discarding read bytes. */
384 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
385 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
388 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
390 s
->physical_offset
= s
->buffer_offset
+ writelen
;
392 /* Don't increment file_length if the file is non-seekable. */
393 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
394 s
->file_length
= s
->physical_offset
;
396 s
->ndirty
-= writelen
;
404 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
407 s
->buffer_offset
= s
->logical_offset
;
409 /* Is the data we want in the buffer? */
410 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
411 && s
->buffer_offset
<= s
->logical_offset
)
412 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
415 /* First copy the active bytes if applicable, then read the rest
416 either directly or filling the buffer. */
419 ssize_t to_read
, did_read
;
420 gfc_offset new_logical
;
423 if (s
->logical_offset
>= s
->buffer_offset
424 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
426 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
427 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
431 /* At this point we consider all bytes in the buffer discarded. */
432 to_read
= nbyte
- nread
;
433 new_logical
= s
->logical_offset
+ nread
;
434 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
435 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
437 s
->buffer_offset
= s
->physical_offset
= new_logical
;
438 if (to_read
<= BUFFER_SIZE
/2)
440 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
441 s
->physical_offset
+= did_read
;
442 s
->active
= did_read
;
443 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
444 memcpy (p
, s
->buffer
, did_read
);
448 did_read
= raw_read (s
, p
, to_read
);
449 s
->physical_offset
+= did_read
;
452 nbyte
= did_read
+ nread
;
454 s
->logical_offset
+= nbyte
;
459 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
462 s
->buffer_offset
= s
->logical_offset
;
464 /* Does the data fit into the buffer? As a special case, if the
465 buffer is empty and the request is bigger than BUFFER_SIZE/2,
466 write directly. This avoids the case where the buffer would have
467 to be flushed at every write. */
468 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
469 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
470 && s
->buffer_offset
<= s
->logical_offset
471 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
473 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
474 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
480 /* Flush, and either fill the buffer with the new data, or if
481 the request is bigger than the buffer size, write directly
482 bypassing the buffer. */
484 if (nbyte
<= BUFFER_SIZE
/2)
486 memcpy (s
->buffer
, buf
, nbyte
);
487 s
->buffer_offset
= s
->logical_offset
;
492 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
493 && lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
495 nbyte
= raw_write (s
, buf
, nbyte
);
496 s
->physical_offset
+= nbyte
;
499 s
->logical_offset
+= nbyte
;
500 /* Don't increment file_length if the file is non-seekable. */
501 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
502 s
->file_length
= s
->logical_offset
;
507 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
514 offset
+= s
->logical_offset
;
517 offset
+= s
->file_length
;
527 s
->logical_offset
= offset
;
532 buf_tell (unix_stream
* s
)
534 return s
->logical_offset
;
538 buf_truncate (unix_stream
* s
, gfc_offset length
)
542 if (buf_flush (s
) != 0)
544 r
= raw_truncate (s
, length
);
546 s
->file_length
= length
;
551 buf_close (unix_stream
* s
)
553 if (buf_flush (s
) != 0)
555 free_mem (s
->buffer
);
556 return raw_close (s
);
560 buf_init (unix_stream
* s
)
562 s
->st
.read
= (void *) buf_read
;
563 s
->st
.write
= (void *) buf_write
;
564 s
->st
.seek
= (void *) buf_seek
;
565 s
->st
.tell
= (void *) buf_tell
;
566 s
->st
.trunc
= (void *) buf_truncate
;
567 s
->st
.close
= (void *) buf_close
;
568 s
->st
.flush
= (void *) buf_flush
;
570 s
->buffer
= get_mem (BUFFER_SIZE
);
575 /*********************************************************************
576 memory stream functions - These are used for internal files
578 The idea here is that a single stream structure is created and all
579 requests must be satisfied from it. The location and size of the
580 buffer is the character variable supplied to the READ or WRITE
583 *********************************************************************/
587 mem_alloc_r (stream
* strm
, int * len
)
589 unix_stream
* s
= (unix_stream
*) strm
;
591 gfc_offset where
= s
->logical_offset
;
593 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
596 n
= s
->buffer_offset
+ s
->active
- where
;
600 s
->logical_offset
= where
+ *len
;
602 return s
->buffer
+ (where
- s
->buffer_offset
);
607 mem_alloc_w (stream
* strm
, int * len
)
609 unix_stream
* s
= (unix_stream
*) strm
;
611 gfc_offset where
= s
->logical_offset
;
615 if (where
< s
->buffer_offset
)
618 if (m
> s
->file_length
)
621 s
->logical_offset
= m
;
623 return s
->buffer
+ (where
- s
->buffer_offset
);
627 /* Stream read function for internal units. */
630 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
635 p
= mem_alloc_r (s
, &nb
);
646 /* Stream write function for internal units. This is not actually used
647 at the moment, as all internal IO is formatted and the formatted IO
648 routines use mem_alloc_w_at. */
651 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
656 p
= mem_alloc_w (s
, &nb
);
668 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
670 unix_stream
* s
= (unix_stream
*) strm
;
676 offset
+= s
->logical_offset
;
679 offset
+= s
->file_length
;
685 /* Note that for internal array I/O it's actually possible to have a
686 negative offset, so don't check for that. */
687 if (offset
> s
->file_length
)
693 s
->logical_offset
= offset
;
695 /* Returning < 0 is the error indicator for sseek(), so return 0 if
696 offset is negative. Thus if the return value is 0, the caller
697 has to use stell() to get the real value of logical_offset. */
705 mem_tell (stream
* s
)
707 return ((unix_stream
*)s
)->logical_offset
;
712 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
713 gfc_offset length
__attribute__ ((unused
)))
720 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
727 mem_close (unix_stream
* s
)
736 /*********************************************************************
737 Public functions -- A reimplementation of this module needs to
738 define functional equivalents of the following.
739 *********************************************************************/
741 /* empty_internal_buffer()-- Zero the buffer of Internal file */
744 empty_internal_buffer(stream
*strm
)
746 unix_stream
* s
= (unix_stream
*) strm
;
747 memset(s
->buffer
, ' ', s
->file_length
);
750 /* open_internal()-- Returns a stream structure from an internal file */
753 open_internal (char *base
, int length
, gfc_offset offset
)
757 s
= get_mem (sizeof (unix_stream
));
758 memset (s
, '\0', sizeof (unix_stream
));
761 s
->buffer_offset
= offset
;
763 s
->logical_offset
= 0;
764 s
->active
= s
->file_length
= length
;
766 s
->st
.close
= (void *) mem_close
;
767 s
->st
.seek
= (void *) mem_seek
;
768 s
->st
.tell
= (void *) mem_tell
;
769 s
->st
.trunc
= (void *) mem_truncate
;
770 s
->st
.read
= (void *) mem_read
;
771 s
->st
.write
= (void *) mem_write
;
772 s
->st
.flush
= (void *) mem_flush
;
778 /* fd_to_stream()-- Given an open file descriptor, build a stream
782 fd_to_stream (int fd
, int prot
)
787 s
= get_mem (sizeof (unix_stream
));
788 memset (s
, '\0', sizeof (unix_stream
));
791 s
->buffer_offset
= 0;
792 s
->physical_offset
= 0;
793 s
->logical_offset
= 0;
796 /* Get the current length of the file. */
798 fstat (fd
, &statbuf
);
800 if (lseek (fd
, 0, SEEK_CUR
) == (gfc_offset
) -1)
803 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
805 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
807 if (isatty (s
->fd
) || options
.all_unbuffered
808 ||(options
.unbuffered_preconnected
&&
809 (s
->fd
== STDIN_FILENO
810 || s
->fd
== STDOUT_FILENO
811 || s
->fd
== STDERR_FILENO
)))
820 /* Given the Fortran unit number, convert it to a C file descriptor. */
823 unit_to_fd (int unit
)
828 us
= find_unit (unit
);
832 fd
= ((unix_stream
*) us
->s
)->fd
;
838 /* unpack_filename()-- Given a fortran string and a pointer to a
839 * buffer that is PATH_MAX characters, convert the fortran string to a
840 * C string in the buffer. Returns nonzero if this is not possible. */
843 unpack_filename (char *cstring
, const char *fstring
, int len
)
845 len
= fstrlen (fstring
, len
);
849 memmove (cstring
, fstring
, len
);
856 /* tempfile()-- Generate a temporary filename for a scratch file and
857 * open it. mkstemp() opens the file for reading and writing, but the
858 * library mode prevents anything that is not allowed. The descriptor
859 * is returned, which is -1 on error. The template is pointed to by
860 * opp->file, which is copied into the unit structure
861 * and freed later. */
864 tempfile (st_parameter_open
*opp
)
870 tempdir
= getenv ("GFORTRAN_TMPDIR");
872 tempdir
= getenv ("TMP");
874 tempdir
= getenv ("TEMP");
876 tempdir
= DEFAULT_TEMPDIR
;
878 template = get_mem (strlen (tempdir
) + 20);
880 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
884 fd
= mkstemp (template);
886 #else /* HAVE_MKSTEMP */
888 if (mktemp (template))
890 #if defined(HAVE_CRLF) && defined(O_BINARY)
891 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
894 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
896 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
900 #endif /* HAVE_MKSTEMP */
906 opp
->file
= template;
907 opp
->file_len
= strlen (template); /* Don't include trailing nul */
914 /* regular_file()-- Open a regular file.
915 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
916 * unless an error occurs.
917 * Returns the descriptor, which is less than zero on error. */
920 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
922 char path
[PATH_MAX
+ 1];
928 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
930 errno
= ENOENT
; /* Fake an OS error */
935 if (opp
->file_len
== 7)
937 if (strncmp (path
, "CONOUT$", 7) == 0
938 || strncmp (path
, "CONERR$", 7) == 0)
940 fd
= open ("/dev/conout", O_WRONLY
);
941 flags
->action
= ACTION_WRITE
;
946 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
948 fd
= open ("/dev/conin", O_RDONLY
);
949 flags
->action
= ACTION_READ
;
956 if (opp
->file_len
== 7)
958 if (strncmp (path
, "CONOUT$", 7) == 0
959 || strncmp (path
, "CONERR$", 7) == 0)
961 fd
= open ("CONOUT$", O_WRONLY
);
962 flags
->action
= ACTION_WRITE
;
967 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
969 fd
= open ("CONIN$", O_RDONLY
);
970 flags
->action
= ACTION_READ
;
977 switch (flags
->action
)
987 case ACTION_READWRITE
:
988 case ACTION_UNSPECIFIED
:
993 internal_error (&opp
->common
, "regular_file(): Bad action");
996 switch (flags
->status
)
999 crflag
= O_CREAT
| O_EXCL
;
1002 case STATUS_OLD
: /* open will fail if the file does not exist*/
1006 case STATUS_UNKNOWN
:
1007 case STATUS_SCRATCH
:
1011 case STATUS_REPLACE
:
1012 crflag
= O_CREAT
| O_TRUNC
;
1016 internal_error (&opp
->common
, "regular_file(): Bad status");
1019 /* rwflag |= O_LARGEFILE; */
1021 #if defined(HAVE_CRLF) && defined(O_BINARY)
1025 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1026 fd
= open (path
, rwflag
| crflag
, mode
);
1027 if (flags
->action
!= ACTION_UNSPECIFIED
)
1032 flags
->action
= ACTION_READWRITE
;
1035 if (errno
!= EACCES
&& errno
!= EROFS
)
1038 /* retry for read-only access */
1040 fd
= open (path
, rwflag
| crflag
, mode
);
1043 flags
->action
= ACTION_READ
;
1044 return fd
; /* success */
1047 if (errno
!= EACCES
)
1048 return fd
; /* failure */
1050 /* retry for write-only access */
1052 fd
= open (path
, rwflag
| crflag
, mode
);
1055 flags
->action
= ACTION_WRITE
;
1056 return fd
; /* success */
1058 return fd
; /* failure */
1062 /* open_external()-- Open an external file, unix specific version.
1063 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1064 * Returns NULL on operating system error. */
1067 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1071 if (flags
->status
== STATUS_SCRATCH
)
1073 fd
= tempfile (opp
);
1074 if (flags
->action
== ACTION_UNSPECIFIED
)
1075 flags
->action
= ACTION_READWRITE
;
1077 #if HAVE_UNLINK_OPEN_FILE
1078 /* We can unlink scratch files now and it will go away when closed. */
1085 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1087 fd
= regular_file (opp
, flags
);
1094 switch (flags
->action
)
1104 case ACTION_READWRITE
:
1105 prot
= PROT_READ
| PROT_WRITE
;
1109 internal_error (&opp
->common
, "open_external(): Bad action");
1112 return fd_to_stream (fd
, prot
);
1116 /* input_stream()-- Return a stream pointer to the default input stream.
1117 * Called on initialization. */
1122 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1126 /* output_stream()-- Return a stream pointer to the default output stream.
1127 * Called on initialization. */
1130 output_stream (void)
1134 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1135 setmode (STDOUT_FILENO
, O_BINARY
);
1138 s
= fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1143 /* error_stream()-- Return a stream pointer to the default error stream.
1144 * Called on initialization. */
1151 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1152 setmode (STDERR_FILENO
, O_BINARY
);
1155 s
= fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1160 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1161 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1162 is big enough to completely fill a 80x25 terminal, so it shuld be
1163 OK. We use a direct write() because it is simpler and least likely
1164 to be clobbered by memory corruption. Writing an error message
1165 longer than that is an error. */
1167 #define ST_VPRINTF_SIZE 2048
1170 st_vprintf (const char *format
, va_list ap
)
1172 static char buffer
[ST_VPRINTF_SIZE
];
1176 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1177 #ifdef HAVE_VSNPRINTF
1178 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1180 written
= vsprintf(buffer
, format
, ap
);
1182 if (written
>= ST_VPRINTF_SIZE
-1)
1184 /* The error message was longer than our buffer. Ouch. Because
1185 we may have messed up things badly, report the error and
1187 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1188 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1189 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1191 #undef ERROR_MESSAGE
1196 written
= write (fd
, buffer
, written
);
1200 /* st_printf()-- printf() function for error output. This just calls
1201 st_vprintf() to do the actual work. */
1204 st_printf (const char *format
, ...)
1208 va_start (ap
, format
);
1209 written
= st_vprintf(format
, ap
);
1215 /* compare_file_filename()-- Given an open stream and a fortran string
1216 * that is a filename, figure out if the file is the same as the
1220 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1222 char path
[PATH_MAX
+ 1];
1224 #ifdef HAVE_WORKING_STAT
1232 if (unpack_filename (path
, name
, len
))
1233 return 0; /* Can't be the same */
1235 /* If the filename doesn't exist, then there is no match with the
1238 if (stat (path
, &st1
) < 0)
1241 #ifdef HAVE_WORKING_STAT
1242 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1243 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1247 /* We try to match files by a unique ID. On some filesystems (network
1248 fs and FAT), we can't generate this unique ID, and will simply compare
1250 id1
= id_from_path (path
);
1251 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1253 return (id1
== id2
);
1256 if (len
!= u
->file_len
)
1258 return (memcmp(path
, u
->file
, len
) == 0);
1263 #ifdef HAVE_WORKING_STAT
1264 # define FIND_FILE0_DECL struct stat *st
1265 # define FIND_FILE0_ARGS st
1267 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1268 # define FIND_FILE0_ARGS id, file, file_len
1271 /* find_file0()-- Recursive work function for find_file() */
1274 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1277 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1284 #ifdef HAVE_WORKING_STAT
1286 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1287 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1291 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1298 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1302 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1306 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1314 /* find_file()-- Take the current filename and see if there is a unit
1315 * that has the file already open. Returns a pointer to the unit if so. */
1318 find_file (const char *file
, gfc_charlen_type file_len
)
1320 char path
[PATH_MAX
+ 1];
1323 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1327 if (unpack_filename (path
, file
, file_len
))
1330 if (stat (path
, &st
[0]) < 0)
1333 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1334 id
= id_from_path (path
);
1337 __gthread_mutex_lock (&unit_lock
);
1339 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1343 if (! __gthread_mutex_trylock (&u
->lock
))
1345 /* assert (u->closed == 0); */
1346 __gthread_mutex_unlock (&unit_lock
);
1350 inc_waiting_locked (u
);
1352 __gthread_mutex_unlock (&unit_lock
);
1355 __gthread_mutex_lock (&u
->lock
);
1358 __gthread_mutex_lock (&unit_lock
);
1359 __gthread_mutex_unlock (&u
->lock
);
1360 if (predec_waiting_locked (u
) == 0)
1365 dec_waiting_unlocked (u
);
1371 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1375 if (u
->unit_number
> min_unit
)
1377 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1381 if (u
->unit_number
>= min_unit
)
1383 if (__gthread_mutex_trylock (&u
->lock
))
1387 __gthread_mutex_unlock (&u
->lock
);
1395 flush_all_units (void)
1400 __gthread_mutex_lock (&unit_lock
);
1403 u
= flush_all_units_1 (unit_root
, min_unit
);
1405 inc_waiting_locked (u
);
1406 __gthread_mutex_unlock (&unit_lock
);
1410 __gthread_mutex_lock (&u
->lock
);
1412 min_unit
= u
->unit_number
+ 1;
1417 __gthread_mutex_lock (&unit_lock
);
1418 __gthread_mutex_unlock (&u
->lock
);
1419 (void) predec_waiting_locked (u
);
1423 __gthread_mutex_lock (&unit_lock
);
1424 __gthread_mutex_unlock (&u
->lock
);
1425 if (predec_waiting_locked (u
) == 0)
1433 /* delete_file()-- Given a unit structure, delete the file associated
1434 * with the unit. Returns nonzero if something went wrong. */
1437 delete_file (gfc_unit
* u
)
1439 char path
[PATH_MAX
+ 1];
1441 if (unpack_filename (path
, u
->file
, u
->file_len
))
1442 { /* Shouldn't be possible */
1447 return unlink (path
);
1451 /* file_exists()-- Returns nonzero if the current filename exists on
1455 file_exists (const char *file
, gfc_charlen_type file_len
)
1457 char path
[PATH_MAX
+ 1];
1458 struct stat statbuf
;
1460 if (unpack_filename (path
, file
, file_len
))
1463 if (stat (path
, &statbuf
) < 0)
1471 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1473 /* inquire_sequential()-- Given a fortran string, determine if the
1474 * file is suitable for sequential access. Returns a C-style
1478 inquire_sequential (const char *string
, int len
)
1480 char path
[PATH_MAX
+ 1];
1481 struct stat statbuf
;
1483 if (string
== NULL
||
1484 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1487 if (S_ISREG (statbuf
.st_mode
) ||
1488 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1491 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1498 /* inquire_direct()-- Given a fortran string, determine if the file is
1499 * suitable for direct access. Returns a C-style string. */
1502 inquire_direct (const char *string
, int len
)
1504 char path
[PATH_MAX
+ 1];
1505 struct stat statbuf
;
1507 if (string
== NULL
||
1508 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1511 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1514 if (S_ISDIR (statbuf
.st_mode
) ||
1515 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1522 /* inquire_formatted()-- Given a fortran string, determine if the file
1523 * is suitable for formatted form. Returns a C-style string. */
1526 inquire_formatted (const char *string
, int len
)
1528 char path
[PATH_MAX
+ 1];
1529 struct stat statbuf
;
1531 if (string
== NULL
||
1532 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1535 if (S_ISREG (statbuf
.st_mode
) ||
1536 S_ISBLK (statbuf
.st_mode
) ||
1537 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1540 if (S_ISDIR (statbuf
.st_mode
))
1547 /* inquire_unformatted()-- Given a fortran string, determine if the file
1548 * is suitable for unformatted form. Returns a C-style string. */
1551 inquire_unformatted (const char *string
, int len
)
1553 return inquire_formatted (string
, len
);
1567 /* Fallback implementation of access() on systems that don't have it.
1568 Only modes R_OK and W_OK are used in this file. */
1571 fallback_access (const char *path
, int mode
)
1573 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
1576 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
1583 #define access fallback_access
1587 /* inquire_access()-- Given a fortran string, determine if the file is
1588 * suitable for access. */
1591 inquire_access (const char *string
, int len
, int mode
)
1593 char path
[PATH_MAX
+ 1];
1595 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1596 access (path
, mode
) < 0)
1603 /* inquire_read()-- Given a fortran string, determine if the file is
1604 * suitable for READ access. */
1607 inquire_read (const char *string
, int len
)
1609 return inquire_access (string
, len
, R_OK
);
1613 /* inquire_write()-- Given a fortran string, determine if the file is
1614 * suitable for READ access. */
1617 inquire_write (const char *string
, int len
)
1619 return inquire_access (string
, len
, W_OK
);
1623 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1624 * suitable for read and write access. */
1627 inquire_readwrite (const char *string
, int len
)
1629 return inquire_access (string
, len
, R_OK
| W_OK
);
1633 /* file_length()-- Return the file length in bytes, -1 if unknown */
1636 file_length (stream
* s
)
1638 gfc_offset curr
, end
;
1639 if (!is_seekable (s
))
1644 end
= sseek (s
, 0, SEEK_END
);
1645 sseek (s
, curr
, SEEK_SET
);
1650 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1654 is_seekable (stream
*s
)
1656 /* By convention, if file_length == -1, the file is not
1658 return ((unix_stream
*) s
)->file_length
!=-1;
1662 /* is_special()-- Return nonzero if the stream is not a regular file. */
1665 is_special (stream
*s
)
1667 return ((unix_stream
*) s
)->special_file
;
1672 stream_isatty (stream
*s
)
1674 return isatty (((unix_stream
*) s
)->fd
);
1678 stream_ttyname (stream
*s
__attribute__ ((unused
)))
1681 return ttyname (((unix_stream
*) s
)->fd
);
1688 /* How files are stored: This is an operating-system specific issue,
1689 and therefore belongs here. There are three cases to consider.
1692 Records are written as block of bytes corresponding to the record
1693 length of the file. This goes for both formatted and unformatted
1694 records. Positioning is done explicitly for each data transfer,
1695 so positioning is not much of an issue.
1697 Sequential Formatted:
1698 Records are separated by newline characters. The newline character
1699 is prohibited from appearing in a string. If it does, this will be
1700 messed up on the next read. End of file is also the end of a record.
1702 Sequential Unformatted:
1703 In this case, we are merely copying bytes to and from main storage,
1704 yet we need to keep track of varying record lengths. We adopt
1705 the solution used by f2c. Each record contains a pair of length
1708 Length of record n in bytes
1710 Length of record n in bytes
1712 Length of record n+1 in bytes
1714 Length of record n+1 in bytes
1716 The length is stored at the end of a record to allow backspacing to the
1717 previous record. Between data transfer statements, the file pointer
1718 is left pointing to the first length of the current record.
1720 ENDFILE records are never explicitly stored.