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. */
47 #define WIN32_LEAN_AND_MEAN
50 #define lseek _lseeki64
51 #define fstat _fstati64
53 typedef struct _stati64 gfstat_t
;
55 #ifndef HAVE_WORKING_STAT
57 id_from_handle (HANDLE hFile
)
59 BY_HANDLE_FILE_INFORMATION FileInformation
;
61 if (hFile
== INVALID_HANDLE_VALUE
)
64 memset (&FileInformation
, 0, sizeof(FileInformation
));
65 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
68 return ((uint64_t) FileInformation
.nFileIndexLow
)
69 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
74 id_from_path (const char *path
)
79 if (!path
|| !*path
|| access (path
, F_OK
))
82 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
83 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
85 res
= id_from_handle (hFile
);
92 id_from_fd (const int fd
)
94 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
100 typedef struct stat gfstat_t
;
104 #define PATH_MAX 1024
115 /* These flags aren't defined on all targets (mingw32), so provide them
134 /* Unix and internal stream I/O module */
136 static const int BUFFER_SIZE
= 8192;
142 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
143 gfc_offset physical_offset
; /* Current physical file offset */
144 gfc_offset logical_offset
; /* Current logical file offset */
145 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
147 char *buffer
; /* Pointer to the buffer. */
148 int fd
; /* The POSIX file descriptor. */
150 int active
; /* Length of valid bytes in the buffer */
153 int ndirty
; /* Dirty bytes starting at buffer_offset */
155 int special_file
; /* =1 if the fd refers to a special file */
160 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
161 * standard descriptors, returning a non-standard descriptor. If the
162 * user specifies that system errors should go to standard output,
163 * then closes standard output, we don't want the system errors to a
164 * file that has been given file descriptor 1 or 0. We want to send
165 * the error to the invalid descriptor. */
171 int input
, output
, error
;
173 input
= output
= error
= 0;
175 /* Unix allocates the lowest descriptors first, so a loop is not
176 required, but this order is. */
177 if (fd
== STDIN_FILENO
)
182 if (fd
== STDOUT_FILENO
)
187 if (fd
== STDERR_FILENO
)
194 close (STDIN_FILENO
);
196 close (STDOUT_FILENO
);
198 close (STDERR_FILENO
);
205 /* If the stream corresponds to a preconnected unit, we flush the
206 corresponding C stream. This is bugware for mixed C-Fortran codes
207 where the C code doesn't flush I/O before returning. */
209 flush_if_preconnected (stream
* s
)
213 fd
= ((unix_stream
*) s
)->fd
;
214 if (fd
== STDIN_FILENO
)
216 else if (fd
== STDOUT_FILENO
)
218 else if (fd
== STDERR_FILENO
)
223 /* get_oserror()-- Get the most recent operating system error. For
224 * unix, this is errno. */
229 return strerror (errno
);
233 /********************************************************************
234 Raw I/O functions (read, write, seek, tell, truncate, close).
236 These functions wrap the basic POSIX I/O syscalls. Any deviation in
237 semantics is a bug, except the following: write restarts in case
238 of being interrupted by a signal, and as the first argument the
239 functions take the unix_stream struct rather than an integer file
240 descriptor. Also, for POSIX read() and write() a nbyte argument larger
241 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
242 than size_t as for POSIX read/write.
243 *********************************************************************/
246 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
252 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
254 /* For read we can't do I/O in a loop like raw_write does, because
255 that will break applications that wait for interactive I/O. */
256 return read (s
->fd
, buf
, nbyte
);
260 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
262 ssize_t trans
, bytes_left
;
266 buf_st
= (char *) buf
;
268 /* We must write in a loop since some systems don't restart system
269 calls in case of a signal. */
270 while (bytes_left
> 0)
272 trans
= write (s
->fd
, buf_st
, bytes_left
);
284 return nbyte
- bytes_left
;
288 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
290 return lseek (s
->fd
, offset
, whence
);
294 raw_tell (unix_stream
* s
)
296 return lseek (s
->fd
, 0, SEEK_CUR
);
300 raw_truncate (unix_stream
* s
, gfc_offset length
)
311 h
= _get_osfhandle (s
->fd
);
312 if (h
== INVALID_HANDLE_VALUE
)
317 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
320 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
322 if (!SetEndOfFile (h
))
327 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
331 lseek (s
->fd
, cur
, SEEK_SET
);
333 #elif defined HAVE_FTRUNCATE
334 return ftruncate (s
->fd
, length
);
335 #elif defined HAVE_CHSIZE
336 return chsize (s
->fd
, length
);
338 runtime_error ("required ftruncate or chsize support not present");
344 raw_close (unix_stream
* s
)
348 if (s
->fd
!= STDOUT_FILENO
349 && s
->fd
!= STDERR_FILENO
350 && s
->fd
!= STDIN_FILENO
)
351 retval
= close (s
->fd
);
359 raw_init (unix_stream
* s
)
361 s
->st
.read
= (void *) raw_read
;
362 s
->st
.write
= (void *) raw_write
;
363 s
->st
.seek
= (void *) raw_seek
;
364 s
->st
.tell
= (void *) raw_tell
;
365 s
->st
.trunc
= (void *) raw_truncate
;
366 s
->st
.close
= (void *) raw_close
;
367 s
->st
.flush
= (void *) raw_flush
;
374 /*********************************************************************
375 Buffered I/O functions. These functions have the same semantics as the
376 raw I/O functions above, except that they are buffered in order to
377 improve performance. The buffer must be flushed when switching from
378 reading to writing and vice versa.
379 *********************************************************************/
382 buf_flush (unix_stream
* s
)
386 /* Flushing in read mode means discarding read bytes. */
392 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
393 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
396 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
398 s
->physical_offset
= s
->buffer_offset
+ writelen
;
400 /* Don't increment file_length if the file is non-seekable. */
401 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
402 s
->file_length
= s
->physical_offset
;
404 s
->ndirty
-= writelen
;
412 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
415 s
->buffer_offset
= s
->logical_offset
;
417 /* Is the data we want in the buffer? */
418 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
419 && s
->buffer_offset
<= s
->logical_offset
)
420 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
423 /* First copy the active bytes if applicable, then read the rest
424 either directly or filling the buffer. */
427 ssize_t to_read
, did_read
;
428 gfc_offset new_logical
;
431 if (s
->logical_offset
>= s
->buffer_offset
432 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
434 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
435 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
439 /* At this point we consider all bytes in the buffer discarded. */
440 to_read
= nbyte
- nread
;
441 new_logical
= s
->logical_offset
+ nread
;
442 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
443 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
445 s
->buffer_offset
= s
->physical_offset
= new_logical
;
446 if (to_read
<= BUFFER_SIZE
/2)
448 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
449 s
->physical_offset
+= did_read
;
450 s
->active
= did_read
;
451 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
452 memcpy (p
, s
->buffer
, did_read
);
456 did_read
= raw_read (s
, p
, to_read
);
457 s
->physical_offset
+= did_read
;
460 nbyte
= did_read
+ nread
;
462 s
->logical_offset
+= nbyte
;
467 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
470 s
->buffer_offset
= s
->logical_offset
;
472 /* Does the data fit into the buffer? As a special case, if the
473 buffer is empty and the request is bigger than BUFFER_SIZE/2,
474 write directly. This avoids the case where the buffer would have
475 to be flushed at every write. */
476 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
477 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
478 && s
->buffer_offset
<= s
->logical_offset
479 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
481 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
482 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
488 /* Flush, and either fill the buffer with the new data, or if
489 the request is bigger than the buffer size, write directly
490 bypassing the buffer. */
492 if (nbyte
<= BUFFER_SIZE
/2)
494 memcpy (s
->buffer
, buf
, nbyte
);
495 s
->buffer_offset
= s
->logical_offset
;
500 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
501 && lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
503 nbyte
= raw_write (s
, buf
, nbyte
);
504 s
->physical_offset
+= nbyte
;
507 s
->logical_offset
+= nbyte
;
508 /* Don't increment file_length if the file is non-seekable. */
509 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
510 s
->file_length
= s
->logical_offset
;
515 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
522 offset
+= s
->logical_offset
;
525 offset
+= s
->file_length
;
535 s
->logical_offset
= offset
;
540 buf_tell (unix_stream
* s
)
542 return s
->logical_offset
;
546 buf_truncate (unix_stream
* s
, gfc_offset length
)
550 if (buf_flush (s
) != 0)
552 r
= raw_truncate (s
, length
);
554 s
->file_length
= length
;
559 buf_close (unix_stream
* s
)
561 if (buf_flush (s
) != 0)
563 free_mem (s
->buffer
);
564 return raw_close (s
);
568 buf_init (unix_stream
* s
)
570 s
->st
.read
= (void *) buf_read
;
571 s
->st
.write
= (void *) buf_write
;
572 s
->st
.seek
= (void *) buf_seek
;
573 s
->st
.tell
= (void *) buf_tell
;
574 s
->st
.trunc
= (void *) buf_truncate
;
575 s
->st
.close
= (void *) buf_close
;
576 s
->st
.flush
= (void *) buf_flush
;
578 s
->buffer
= get_mem (BUFFER_SIZE
);
583 /*********************************************************************
584 memory stream functions - These are used for internal files
586 The idea here is that a single stream structure is created and all
587 requests must be satisfied from it. The location and size of the
588 buffer is the character variable supplied to the READ or WRITE
591 *********************************************************************/
595 mem_alloc_r (stream
* strm
, int * len
)
597 unix_stream
* s
= (unix_stream
*) strm
;
599 gfc_offset where
= s
->logical_offset
;
601 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
604 n
= s
->buffer_offset
+ s
->active
- where
;
608 s
->logical_offset
= where
+ *len
;
610 return s
->buffer
+ (where
- s
->buffer_offset
);
615 mem_alloc_w (stream
* strm
, int * len
)
617 unix_stream
* s
= (unix_stream
*) strm
;
619 gfc_offset where
= s
->logical_offset
;
623 if (where
< s
->buffer_offset
)
626 if (m
> s
->file_length
)
629 s
->logical_offset
= m
;
631 return s
->buffer
+ (where
- s
->buffer_offset
);
635 /* Stream read function for internal units. */
638 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
643 p
= mem_alloc_r (s
, &nb
);
654 /* Stream write function for internal units. This is not actually used
655 at the moment, as all internal IO is formatted and the formatted IO
656 routines use mem_alloc_w_at. */
659 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
664 p
= mem_alloc_w (s
, &nb
);
676 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
678 unix_stream
* s
= (unix_stream
*) strm
;
684 offset
+= s
->logical_offset
;
687 offset
+= s
->file_length
;
693 /* Note that for internal array I/O it's actually possible to have a
694 negative offset, so don't check for that. */
695 if (offset
> s
->file_length
)
701 s
->logical_offset
= offset
;
703 /* Returning < 0 is the error indicator for sseek(), so return 0 if
704 offset is negative. Thus if the return value is 0, the caller
705 has to use stell() to get the real value of logical_offset. */
713 mem_tell (stream
* s
)
715 return ((unix_stream
*)s
)->logical_offset
;
720 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
721 gfc_offset length
__attribute__ ((unused
)))
728 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
735 mem_close (unix_stream
* s
)
744 /*********************************************************************
745 Public functions -- A reimplementation of this module needs to
746 define functional equivalents of the following.
747 *********************************************************************/
749 /* empty_internal_buffer()-- Zero the buffer of Internal file */
752 empty_internal_buffer(stream
*strm
)
754 unix_stream
* s
= (unix_stream
*) strm
;
755 memset(s
->buffer
, ' ', s
->file_length
);
758 /* open_internal()-- Returns a stream structure from an internal file */
761 open_internal (char *base
, int length
, gfc_offset offset
)
765 s
= get_mem (sizeof (unix_stream
));
766 memset (s
, '\0', sizeof (unix_stream
));
769 s
->buffer_offset
= offset
;
771 s
->logical_offset
= 0;
772 s
->active
= s
->file_length
= length
;
774 s
->st
.close
= (void *) mem_close
;
775 s
->st
.seek
= (void *) mem_seek
;
776 s
->st
.tell
= (void *) mem_tell
;
777 s
->st
.trunc
= (void *) mem_truncate
;
778 s
->st
.read
= (void *) mem_read
;
779 s
->st
.write
= (void *) mem_write
;
780 s
->st
.flush
= (void *) mem_flush
;
786 /* fd_to_stream()-- Given an open file descriptor, build a stream
790 fd_to_stream (int fd
, int prot
)
795 s
= get_mem (sizeof (unix_stream
));
796 memset (s
, '\0', sizeof (unix_stream
));
799 s
->buffer_offset
= 0;
800 s
->physical_offset
= 0;
801 s
->logical_offset
= 0;
804 /* Get the current length of the file. */
806 fstat (fd
, &statbuf
);
808 if (lseek (fd
, 0, SEEK_CUR
) == (gfc_offset
) -1)
811 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
813 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
815 if (isatty (s
->fd
) || options
.all_unbuffered
816 ||(options
.unbuffered_preconnected
&&
817 (s
->fd
== STDIN_FILENO
818 || s
->fd
== STDOUT_FILENO
819 || s
->fd
== STDERR_FILENO
)))
828 /* Given the Fortran unit number, convert it to a C file descriptor. */
831 unit_to_fd (int unit
)
836 us
= find_unit (unit
);
840 fd
= ((unix_stream
*) us
->s
)->fd
;
846 /* unpack_filename()-- Given a fortran string and a pointer to a
847 * buffer that is PATH_MAX characters, convert the fortran string to a
848 * C string in the buffer. Returns nonzero if this is not possible. */
851 unpack_filename (char *cstring
, const char *fstring
, int len
)
853 len
= fstrlen (fstring
, len
);
857 memmove (cstring
, fstring
, len
);
864 /* tempfile()-- Generate a temporary filename for a scratch file and
865 * open it. mkstemp() opens the file for reading and writing, but the
866 * library mode prevents anything that is not allowed. The descriptor
867 * is returned, which is -1 on error. The template is pointed to by
868 * opp->file, which is copied into the unit structure
869 * and freed later. */
872 tempfile (st_parameter_open
*opp
)
878 tempdir
= getenv ("GFORTRAN_TMPDIR");
880 tempdir
= getenv ("TMP");
882 tempdir
= getenv ("TEMP");
884 tempdir
= DEFAULT_TEMPDIR
;
886 template = get_mem (strlen (tempdir
) + 20);
888 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
892 fd
= mkstemp (template);
894 #else /* HAVE_MKSTEMP */
896 if (mktemp (template))
898 #if defined(HAVE_CRLF) && defined(O_BINARY)
899 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
902 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
904 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
908 #endif /* HAVE_MKSTEMP */
914 opp
->file
= template;
915 opp
->file_len
= strlen (template); /* Don't include trailing nul */
922 /* regular_file()-- Open a regular file.
923 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
924 * unless an error occurs.
925 * Returns the descriptor, which is less than zero on error. */
928 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
930 char path
[PATH_MAX
+ 1];
936 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
938 errno
= ENOENT
; /* Fake an OS error */
943 if (opp
->file_len
== 7)
945 if (strncmp (path
, "CONOUT$", 7) == 0
946 || strncmp (path
, "CONERR$", 7) == 0)
948 fd
= open ("/dev/conout", O_WRONLY
);
949 flags
->action
= ACTION_WRITE
;
954 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
956 fd
= open ("/dev/conin", O_RDONLY
);
957 flags
->action
= ACTION_READ
;
964 if (opp
->file_len
== 7)
966 if (strncmp (path
, "CONOUT$", 7) == 0
967 || strncmp (path
, "CONERR$", 7) == 0)
969 fd
= open ("CONOUT$", O_WRONLY
);
970 flags
->action
= ACTION_WRITE
;
975 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
977 fd
= open ("CONIN$", O_RDONLY
);
978 flags
->action
= ACTION_READ
;
985 switch (flags
->action
)
995 case ACTION_READWRITE
:
996 case ACTION_UNSPECIFIED
:
1001 internal_error (&opp
->common
, "regular_file(): Bad action");
1004 switch (flags
->status
)
1007 crflag
= O_CREAT
| O_EXCL
;
1010 case STATUS_OLD
: /* open will fail if the file does not exist*/
1014 case STATUS_UNKNOWN
:
1015 case STATUS_SCRATCH
:
1019 case STATUS_REPLACE
:
1020 crflag
= O_CREAT
| O_TRUNC
;
1024 internal_error (&opp
->common
, "regular_file(): Bad status");
1027 /* rwflag |= O_LARGEFILE; */
1029 #if defined(HAVE_CRLF) && defined(O_BINARY)
1033 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1034 fd
= open (path
, rwflag
| crflag
, mode
);
1035 if (flags
->action
!= ACTION_UNSPECIFIED
)
1040 flags
->action
= ACTION_READWRITE
;
1043 if (errno
!= EACCES
&& errno
!= EROFS
)
1046 /* retry for read-only access */
1048 fd
= open (path
, rwflag
| crflag
, mode
);
1051 flags
->action
= ACTION_READ
;
1052 return fd
; /* success */
1055 if (errno
!= EACCES
)
1056 return fd
; /* failure */
1058 /* retry for write-only access */
1060 fd
= open (path
, rwflag
| crflag
, mode
);
1063 flags
->action
= ACTION_WRITE
;
1064 return fd
; /* success */
1066 return fd
; /* failure */
1070 /* open_external()-- Open an external file, unix specific version.
1071 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1072 * Returns NULL on operating system error. */
1075 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1079 if (flags
->status
== STATUS_SCRATCH
)
1081 fd
= tempfile (opp
);
1082 if (flags
->action
== ACTION_UNSPECIFIED
)
1083 flags
->action
= ACTION_READWRITE
;
1085 #if HAVE_UNLINK_OPEN_FILE
1086 /* We can unlink scratch files now and it will go away when closed. */
1093 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1095 fd
= regular_file (opp
, flags
);
1102 switch (flags
->action
)
1112 case ACTION_READWRITE
:
1113 prot
= PROT_READ
| PROT_WRITE
;
1117 internal_error (&opp
->common
, "open_external(): Bad action");
1120 return fd_to_stream (fd
, prot
);
1124 /* input_stream()-- Return a stream pointer to the default input stream.
1125 * Called on initialization. */
1130 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1134 /* output_stream()-- Return a stream pointer to the default output stream.
1135 * Called on initialization. */
1138 output_stream (void)
1142 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1143 setmode (STDOUT_FILENO
, O_BINARY
);
1146 s
= fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1151 /* error_stream()-- Return a stream pointer to the default error stream.
1152 * Called on initialization. */
1159 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1160 setmode (STDERR_FILENO
, O_BINARY
);
1163 s
= fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1168 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1169 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1170 is big enough to completely fill a 80x25 terminal, so it shuld be
1171 OK. We use a direct write() because it is simpler and least likely
1172 to be clobbered by memory corruption. Writing an error message
1173 longer than that is an error. */
1175 #define ST_VPRINTF_SIZE 2048
1178 st_vprintf (const char *format
, va_list ap
)
1180 static char buffer
[ST_VPRINTF_SIZE
];
1184 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1185 #ifdef HAVE_VSNPRINTF
1186 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1188 written
= vsprintf(buffer
, format
, ap
);
1190 if (written
>= ST_VPRINTF_SIZE
-1)
1192 /* The error message was longer than our buffer. Ouch. Because
1193 we may have messed up things badly, report the error and
1195 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1196 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1197 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1199 #undef ERROR_MESSAGE
1204 written
= write (fd
, buffer
, written
);
1208 /* st_printf()-- printf() function for error output. This just calls
1209 st_vprintf() to do the actual work. */
1212 st_printf (const char *format
, ...)
1216 va_start (ap
, format
);
1217 written
= st_vprintf(format
, ap
);
1223 /* compare_file_filename()-- Given an open stream and a fortran string
1224 * that is a filename, figure out if the file is the same as the
1228 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1230 char path
[PATH_MAX
+ 1];
1232 #ifdef HAVE_WORKING_STAT
1240 if (unpack_filename (path
, name
, len
))
1241 return 0; /* Can't be the same */
1243 /* If the filename doesn't exist, then there is no match with the
1246 if (stat (path
, &st1
) < 0)
1249 #ifdef HAVE_WORKING_STAT
1250 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1251 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1255 /* We try to match files by a unique ID. On some filesystems (network
1256 fs and FAT), we can't generate this unique ID, and will simply compare
1258 id1
= id_from_path (path
);
1259 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1261 return (id1
== id2
);
1264 if (len
!= u
->file_len
)
1266 return (memcmp(path
, u
->file
, len
) == 0);
1271 #ifdef HAVE_WORKING_STAT
1272 # define FIND_FILE0_DECL gfstat_t *st
1273 # define FIND_FILE0_ARGS st
1275 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1276 # define FIND_FILE0_ARGS id, file, file_len
1279 /* find_file0()-- Recursive work function for find_file() */
1282 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1285 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1292 #ifdef HAVE_WORKING_STAT
1294 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1295 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1299 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1306 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1310 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1314 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1322 /* find_file()-- Take the current filename and see if there is a unit
1323 * that has the file already open. Returns a pointer to the unit if so. */
1326 find_file (const char *file
, gfc_charlen_type file_len
)
1328 char path
[PATH_MAX
+ 1];
1331 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1335 if (unpack_filename (path
, file
, file_len
))
1338 if (stat (path
, &st
[0]) < 0)
1341 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1342 id
= id_from_path (path
);
1345 __gthread_mutex_lock (&unit_lock
);
1347 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1351 if (! __gthread_mutex_trylock (&u
->lock
))
1353 /* assert (u->closed == 0); */
1354 __gthread_mutex_unlock (&unit_lock
);
1358 inc_waiting_locked (u
);
1360 __gthread_mutex_unlock (&unit_lock
);
1363 __gthread_mutex_lock (&u
->lock
);
1366 __gthread_mutex_lock (&unit_lock
);
1367 __gthread_mutex_unlock (&u
->lock
);
1368 if (predec_waiting_locked (u
) == 0)
1373 dec_waiting_unlocked (u
);
1379 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1383 if (u
->unit_number
> min_unit
)
1385 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1389 if (u
->unit_number
>= min_unit
)
1391 if (__gthread_mutex_trylock (&u
->lock
))
1395 __gthread_mutex_unlock (&u
->lock
);
1403 flush_all_units (void)
1408 __gthread_mutex_lock (&unit_lock
);
1411 u
= flush_all_units_1 (unit_root
, min_unit
);
1413 inc_waiting_locked (u
);
1414 __gthread_mutex_unlock (&unit_lock
);
1418 __gthread_mutex_lock (&u
->lock
);
1420 min_unit
= u
->unit_number
+ 1;
1425 __gthread_mutex_lock (&unit_lock
);
1426 __gthread_mutex_unlock (&u
->lock
);
1427 (void) predec_waiting_locked (u
);
1431 __gthread_mutex_lock (&unit_lock
);
1432 __gthread_mutex_unlock (&u
->lock
);
1433 if (predec_waiting_locked (u
) == 0)
1441 /* delete_file()-- Given a unit structure, delete the file associated
1442 * with the unit. Returns nonzero if something went wrong. */
1445 delete_file (gfc_unit
* u
)
1447 char path
[PATH_MAX
+ 1];
1449 if (unpack_filename (path
, u
->file
, u
->file_len
))
1450 { /* Shouldn't be possible */
1455 return unlink (path
);
1459 /* file_exists()-- Returns nonzero if the current filename exists on
1463 file_exists (const char *file
, gfc_charlen_type file_len
)
1465 char path
[PATH_MAX
+ 1];
1468 if (unpack_filename (path
, file
, file_len
))
1471 if (stat (path
, &statbuf
) < 0)
1479 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1481 /* inquire_sequential()-- Given a fortran string, determine if the
1482 * file is suitable for sequential access. Returns a C-style
1486 inquire_sequential (const char *string
, int len
)
1488 char path
[PATH_MAX
+ 1];
1491 if (string
== NULL
||
1492 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1495 if (S_ISREG (statbuf
.st_mode
) ||
1496 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1499 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1506 /* inquire_direct()-- Given a fortran string, determine if the file is
1507 * suitable for direct access. Returns a C-style string. */
1510 inquire_direct (const char *string
, int len
)
1512 char path
[PATH_MAX
+ 1];
1515 if (string
== NULL
||
1516 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1519 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1522 if (S_ISDIR (statbuf
.st_mode
) ||
1523 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1530 /* inquire_formatted()-- Given a fortran string, determine if the file
1531 * is suitable for formatted form. Returns a C-style string. */
1534 inquire_formatted (const char *string
, int len
)
1536 char path
[PATH_MAX
+ 1];
1539 if (string
== NULL
||
1540 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1543 if (S_ISREG (statbuf
.st_mode
) ||
1544 S_ISBLK (statbuf
.st_mode
) ||
1545 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1548 if (S_ISDIR (statbuf
.st_mode
))
1555 /* inquire_unformatted()-- Given a fortran string, determine if the file
1556 * is suitable for unformatted form. Returns a C-style string. */
1559 inquire_unformatted (const char *string
, int len
)
1561 return inquire_formatted (string
, len
);
1575 /* Fallback implementation of access() on systems that don't have it.
1576 Only modes R_OK and W_OK are used in this file. */
1579 fallback_access (const char *path
, int mode
)
1581 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
1584 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
1591 #define access fallback_access
1595 /* inquire_access()-- Given a fortran string, determine if the file is
1596 * suitable for access. */
1599 inquire_access (const char *string
, int len
, int mode
)
1601 char path
[PATH_MAX
+ 1];
1603 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1604 access (path
, mode
) < 0)
1611 /* inquire_read()-- Given a fortran string, determine if the file is
1612 * suitable for READ access. */
1615 inquire_read (const char *string
, int len
)
1617 return inquire_access (string
, len
, R_OK
);
1621 /* inquire_write()-- Given a fortran string, determine if the file is
1622 * suitable for READ access. */
1625 inquire_write (const char *string
, int len
)
1627 return inquire_access (string
, len
, W_OK
);
1631 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1632 * suitable for read and write access. */
1635 inquire_readwrite (const char *string
, int len
)
1637 return inquire_access (string
, len
, R_OK
| W_OK
);
1641 /* file_length()-- Return the file length in bytes, -1 if unknown */
1644 file_length (stream
* s
)
1646 gfc_offset curr
, end
;
1647 if (!is_seekable (s
))
1652 end
= sseek (s
, 0, SEEK_END
);
1653 sseek (s
, curr
, SEEK_SET
);
1658 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1662 is_seekable (stream
*s
)
1664 /* By convention, if file_length == -1, the file is not
1666 return ((unix_stream
*) s
)->file_length
!=-1;
1670 /* is_special()-- Return nonzero if the stream is not a regular file. */
1673 is_special (stream
*s
)
1675 return ((unix_stream
*) s
)->special_file
;
1680 stream_isatty (stream
*s
)
1682 return isatty (((unix_stream
*) s
)->fd
);
1686 stream_ttyname (stream
*s
__attribute__ ((unused
)))
1689 return ttyname (((unix_stream
*) s
)->fd
);
1696 /* How files are stored: This is an operating-system specific issue,
1697 and therefore belongs here. There are three cases to consider.
1700 Records are written as block of bytes corresponding to the record
1701 length of the file. This goes for both formatted and unformatted
1702 records. Positioning is done explicitly for each data transfer,
1703 so positioning is not much of an issue.
1705 Sequential Formatted:
1706 Records are separated by newline characters. The newline character
1707 is prohibited from appearing in a string. If it does, this will be
1708 messed up on the next read. End of file is also the end of a record.
1710 Sequential Unformatted:
1711 In this case, we are merely copying bytes to and from main storage,
1712 yet we need to keep track of varying record lengths. We adopt
1713 the solution used by f2c. Each record contains a pair of length
1716 Length of record n in bytes
1718 Length of record n in bytes
1720 Length of record n+1 in bytes
1722 Length of record n+1 in bytes
1724 The length is stored at the end of a record to allow backspacing to the
1725 previous record. Between data transfer statements, the file pointer
1726 is left pointing to the first length of the current record.
1728 ENDFILE records are never explicitly stored.