1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
32 /* Unix stream I/O module */
47 /* For mingw, we don't identify files by their inode number, but by a
48 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
49 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
51 #define WIN32_LEAN_AND_MEAN
55 id_from_handle (HANDLE hFile
)
57 BY_HANDLE_FILE_INFORMATION FileInformation
;
59 if (hFile
== INVALID_HANDLE_VALUE
)
62 memset (&FileInformation
, 0, sizeof(FileInformation
));
63 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
66 return ((uint64_t) FileInformation
.nFileIndexLow
)
67 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
72 id_from_path (const char *path
)
77 if (!path
|| !*path
|| access (path
, F_OK
))
80 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
81 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
83 res
= id_from_handle (hFile
);
90 id_from_fd (const int fd
)
92 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
109 /* These flags aren't defined on all targets (mingw32), so provide them
128 /* Unix and internal stream I/O module */
130 static const int BUFFER_SIZE
= 8192;
136 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
137 gfc_offset physical_offset
; /* Current physical file offset */
138 gfc_offset logical_offset
; /* Current logical file offset */
139 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
141 char *buffer
; /* Pointer to the buffer. */
142 int fd
; /* The POSIX file descriptor. */
144 int active
; /* Length of valid bytes in the buffer */
147 int ndirty
; /* Dirty bytes starting at buffer_offset */
149 int special_file
; /* =1 if the fd refers to a special file */
154 /*move_pos_offset()-- Move the record pointer right or left
155 *relative to current position */
158 move_pos_offset (stream
* st
, int pos_off
)
160 unix_stream
* str
= (unix_stream
*)st
;
163 str
->logical_offset
+= pos_off
;
165 if (str
->ndirty
> str
->logical_offset
)
167 if (str
->ndirty
+ pos_off
> 0)
168 str
->ndirty
+= pos_off
;
179 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
180 * standard descriptors, returning a non-standard descriptor. If the
181 * user specifies that system errors should go to standard output,
182 * then closes standard output, we don't want the system errors to a
183 * file that has been given file descriptor 1 or 0. We want to send
184 * the error to the invalid descriptor. */
190 int input
, output
, error
;
192 input
= output
= error
= 0;
194 /* Unix allocates the lowest descriptors first, so a loop is not
195 required, but this order is. */
196 if (fd
== STDIN_FILENO
)
201 if (fd
== STDOUT_FILENO
)
206 if (fd
== STDERR_FILENO
)
213 close (STDIN_FILENO
);
215 close (STDOUT_FILENO
);
217 close (STDERR_FILENO
);
224 is_preconnected (stream
* s
)
228 fd
= ((unix_stream
*) s
)->fd
;
229 if (fd
== STDIN_FILENO
|| fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
)
235 /* If the stream corresponds to a preconnected unit, we flush the
236 corresponding C stream. This is bugware for mixed C-Fortran codes
237 where the C code doesn't flush I/O before returning. */
239 flush_if_preconnected (stream
* s
)
243 fd
= ((unix_stream
*) s
)->fd
;
244 if (fd
== STDIN_FILENO
)
246 else if (fd
== STDOUT_FILENO
)
248 else if (fd
== STDERR_FILENO
)
253 /* get_oserror()-- Get the most recent operating system error. For
254 * unix, this is errno. */
259 return strerror (errno
);
263 /********************************************************************
264 Raw I/O functions (read, write, seek, tell, truncate, close).
266 These functions wrap the basic POSIX I/O syscalls. Any deviation in
267 semantics is a bug, except the following: write restarts in case
268 of being interrupted by a signal, and as the first argument the
269 functions take the unix_stream struct rather than an integer file
270 descriptor. Also, for POSIX read() and write() a nbyte argument larger
271 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
272 than size_t as for POSIX read/write.
273 *********************************************************************/
276 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
282 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
284 /* For read we can't do I/O in a loop like raw_write does, because
285 that will break applications that wait for interactive I/O. */
286 return read (s
->fd
, buf
, nbyte
);
290 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
292 ssize_t trans
, bytes_left
;
296 buf_st
= (char *) buf
;
298 /* We must write in a loop since some systems don't restart system
299 calls in case of a signal. */
300 while (bytes_left
> 0)
302 trans
= write (s
->fd
, buf_st
, bytes_left
);
314 return nbyte
- bytes_left
;
318 raw_seek (unix_stream
* s
, off_t offset
, int whence
)
320 return lseek (s
->fd
, offset
, whence
);
324 raw_tell (unix_stream
* s
)
326 return lseek (s
->fd
, 0, SEEK_CUR
);
330 raw_truncate (unix_stream
* s
, off_t length
)
332 #ifdef HAVE_FTRUNCATE
333 return ftruncate (s
->fd
, length
);
334 #elif defined HAVE_CHSIZE
335 return chsize (s
->fd
, length
);
337 runtime_error ("required ftruncate or chsize support not present");
343 raw_close (unix_stream
* s
)
347 if (s
->fd
!= STDOUT_FILENO
348 && s
->fd
!= STDERR_FILENO
349 && s
->fd
!= STDIN_FILENO
)
350 retval
= close (s
->fd
);
358 raw_init (unix_stream
* s
)
360 s
->st
.read
= (void *) raw_read
;
361 s
->st
.write
= (void *) raw_write
;
362 s
->st
.seek
= (void *) raw_seek
;
363 s
->st
.tell
= (void *) raw_tell
;
364 s
->st
.trunc
= (void *) raw_truncate
;
365 s
->st
.close
= (void *) raw_close
;
366 s
->st
.flush
= (void *) raw_flush
;
373 /*********************************************************************
374 Buffered I/O functions. These functions have the same semantics as the
375 raw I/O functions above, except that they are buffered in order to
376 improve performance. The buffer must be flushed when switching from
377 reading to writing and vice versa.
378 *********************************************************************/
381 buf_flush (unix_stream
* s
)
385 /* Flushing in read mode means discarding read bytes. */
391 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
392 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
395 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
397 s
->physical_offset
= s
->buffer_offset
+ writelen
;
399 /* Don't increment file_length if the file is non-seekable. */
400 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
401 s
->file_length
= s
->physical_offset
;
403 s
->ndirty
-= writelen
;
411 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
414 s
->buffer_offset
= s
->logical_offset
;
416 /* Is the data we want in the buffer? */
417 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
418 && s
->buffer_offset
<= s
->logical_offset
)
419 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
422 /* First copy the active bytes if applicable, then read the rest
423 either directly or filling the buffer. */
426 ssize_t to_read
, did_read
;
427 gfc_offset new_logical
;
430 if (s
->logical_offset
>= s
->buffer_offset
431 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
433 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
434 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
438 /* At this point we consider all bytes in the buffer discarded. */
439 to_read
= nbyte
- nread
;
440 new_logical
= s
->logical_offset
+ nread
;
441 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
442 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
444 s
->buffer_offset
= s
->physical_offset
= new_logical
;
445 if (to_read
<= BUFFER_SIZE
/2)
447 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
448 s
->physical_offset
+= did_read
;
449 s
->active
= did_read
;
450 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
451 memcpy (p
, s
->buffer
, did_read
);
455 did_read
= raw_read (s
, p
, to_read
);
456 s
->physical_offset
+= did_read
;
459 nbyte
= did_read
+ nread
;
461 s
->logical_offset
+= nbyte
;
466 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
469 s
->buffer_offset
= s
->logical_offset
;
471 /* Does the data fit into the buffer? As a special case, if the
472 buffer is empty and the request is bigger than BUFFER_SIZE/2,
473 write directly. This avoids the case where the buffer would have
474 to be flushed at every write. */
475 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
476 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
477 && s
->buffer_offset
<= s
->logical_offset
478 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
480 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
481 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
487 /* Flush, and either fill the buffer with the new data, or if
488 the request is bigger than the buffer size, write directly
489 bypassing the buffer. */
491 if (nbyte
<= BUFFER_SIZE
/2)
493 memcpy (s
->buffer
, buf
, nbyte
);
494 s
->buffer_offset
= s
->logical_offset
;
499 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
500 && lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
502 nbyte
= raw_write (s
, buf
, nbyte
);
503 s
->physical_offset
+= nbyte
;
506 s
->logical_offset
+= nbyte
;
507 /* Don't increment file_length if the file is non-seekable. */
508 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
509 s
->file_length
= s
->logical_offset
;
514 buf_seek (unix_stream
* s
, off_t offset
, int whence
)
521 offset
+= s
->logical_offset
;
524 offset
+= s
->file_length
;
534 s
->logical_offset
= offset
;
539 buf_tell (unix_stream
* s
)
541 return s
->logical_offset
;
545 buf_truncate (unix_stream
* s
, off_t length
)
549 if (buf_flush (s
) != 0)
551 r
= raw_truncate (s
, length
);
553 s
->file_length
= length
;
558 buf_close (unix_stream
* s
)
560 if (buf_flush (s
) != 0)
562 free_mem (s
->buffer
);
563 return raw_close (s
);
567 buf_init (unix_stream
* s
)
569 s
->st
.read
= (void *) buf_read
;
570 s
->st
.write
= (void *) buf_write
;
571 s
->st
.seek
= (void *) buf_seek
;
572 s
->st
.tell
= (void *) buf_tell
;
573 s
->st
.trunc
= (void *) buf_truncate
;
574 s
->st
.close
= (void *) buf_close
;
575 s
->st
.flush
= (void *) buf_flush
;
577 s
->buffer
= get_mem (BUFFER_SIZE
);
582 /*********************************************************************
583 memory stream functions - These are used for internal files
585 The idea here is that a single stream structure is created and all
586 requests must be satisfied from it. The location and size of the
587 buffer is the character variable supplied to the READ or WRITE
590 *********************************************************************/
594 mem_alloc_r (stream
* strm
, int * len
)
596 unix_stream
* s
= (unix_stream
*) strm
;
598 gfc_offset where
= s
->logical_offset
;
600 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
603 n
= s
->buffer_offset
+ s
->active
- where
;
607 s
->logical_offset
= where
+ *len
;
609 return s
->buffer
+ (where
- s
->buffer_offset
);
614 mem_alloc_w (stream
* strm
, int * len
)
616 unix_stream
* s
= (unix_stream
*) strm
;
618 gfc_offset where
= s
->logical_offset
;
622 if (where
< s
->buffer_offset
)
625 if (m
> s
->file_length
)
628 s
->logical_offset
= m
;
630 return s
->buffer
+ (where
- s
->buffer_offset
);
634 /* Stream read function for internal units. */
637 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
642 p
= mem_alloc_r (s
, &nb
);
653 /* Stream write function for internal units. This is not actually used
654 at the moment, as all internal IO is formatted and the formatted IO
655 routines use mem_alloc_w_at. */
658 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
663 p
= mem_alloc_w (s
, &nb
);
675 mem_seek (stream
* strm
, off_t offset
, int whence
)
677 unix_stream
* s
= (unix_stream
*) strm
;
683 offset
+= s
->logical_offset
;
686 offset
+= s
->file_length
;
692 /* Note that for internal array I/O it's actually possible to have a
693 negative offset, so don't check for that. */
694 if (offset
> s
->file_length
)
700 s
->logical_offset
= offset
;
702 /* Returning < 0 is the error indicator for sseek(), so return 0 if
703 offset is negative. Thus if the return value is 0, the caller
704 has to use stell() to get the real value of logical_offset. */
712 mem_tell (stream
* s
)
714 return ((unix_stream
*)s
)->logical_offset
;
719 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
720 off_t length
__attribute__ ((unused
)))
727 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
734 mem_close (unix_stream
* s
)
743 /*********************************************************************
744 Public functions -- A reimplementation of this module needs to
745 define functional equivalents of the following.
746 *********************************************************************/
748 /* empty_internal_buffer()-- Zero the buffer of Internal file */
751 empty_internal_buffer(stream
*strm
)
753 unix_stream
* s
= (unix_stream
*) strm
;
754 memset(s
->buffer
, ' ', s
->file_length
);
757 /* open_internal()-- Returns a stream structure from an internal file */
760 open_internal (char *base
, int length
, gfc_offset offset
)
764 s
= get_mem (sizeof (unix_stream
));
765 memset (s
, '\0', sizeof (unix_stream
));
768 s
->buffer_offset
= offset
;
770 s
->logical_offset
= 0;
771 s
->active
= s
->file_length
= length
;
773 s
->st
.close
= (void *) mem_close
;
774 s
->st
.seek
= (void *) mem_seek
;
775 s
->st
.tell
= (void *) mem_tell
;
776 s
->st
.trunc
= (void *) mem_truncate
;
777 s
->st
.read
= (void *) mem_read
;
778 s
->st
.write
= (void *) mem_write
;
779 s
->st
.flush
= (void *) mem_flush
;
785 /* fd_to_stream()-- Given an open file descriptor, build a stream
789 fd_to_stream (int fd
, int prot
)
794 s
= get_mem (sizeof (unix_stream
));
795 memset (s
, '\0', sizeof (unix_stream
));
798 s
->buffer_offset
= 0;
799 s
->physical_offset
= 0;
800 s
->logical_offset
= 0;
803 /* Get the current length of the file. */
805 fstat (fd
, &statbuf
);
807 if (lseek (fd
, 0, SEEK_CUR
) == (off_t
) -1)
810 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
812 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
814 if (isatty (s
->fd
) || options
.all_unbuffered
815 ||(options
.unbuffered_preconnected
&&
816 (s
->fd
== STDIN_FILENO
817 || s
->fd
== STDOUT_FILENO
818 || s
->fd
== STDERR_FILENO
)))
827 /* Given the Fortran unit number, convert it to a C file descriptor. */
830 unit_to_fd (int unit
)
835 us
= find_unit (unit
);
839 fd
= ((unix_stream
*) us
->s
)->fd
;
845 /* unpack_filename()-- Given a fortran string and a pointer to a
846 * buffer that is PATH_MAX characters, convert the fortran string to a
847 * C string in the buffer. Returns nonzero if this is not possible. */
850 unpack_filename (char *cstring
, const char *fstring
, int len
)
852 len
= fstrlen (fstring
, len
);
856 memmove (cstring
, fstring
, len
);
863 /* tempfile()-- Generate a temporary filename for a scratch file and
864 * open it. mkstemp() opens the file for reading and writing, but the
865 * library mode prevents anything that is not allowed. The descriptor
866 * is returned, which is -1 on error. The template is pointed to by
867 * opp->file, which is copied into the unit structure
868 * and freed later. */
871 tempfile (st_parameter_open
*opp
)
877 tempdir
= getenv ("GFORTRAN_TMPDIR");
879 tempdir
= getenv ("TMP");
881 tempdir
= getenv ("TEMP");
883 tempdir
= DEFAULT_TEMPDIR
;
885 template = get_mem (strlen (tempdir
) + 20);
887 sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
891 fd
= mkstemp (template);
893 #else /* HAVE_MKSTEMP */
895 if (mktemp (template))
897 #if defined(HAVE_CRLF) && defined(O_BINARY)
898 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
901 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
903 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
907 #endif /* HAVE_MKSTEMP */
913 opp
->file
= template;
914 opp
->file_len
= strlen (template); /* Don't include trailing nul */
921 /* regular_file()-- Open a regular file.
922 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
923 * unless an error occurs.
924 * Returns the descriptor, which is less than zero on error. */
927 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
929 char path
[PATH_MAX
+ 1];
935 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
937 errno
= ENOENT
; /* Fake an OS error */
943 switch (flags
->action
)
953 case ACTION_READWRITE
:
954 case ACTION_UNSPECIFIED
:
959 internal_error (&opp
->common
, "regular_file(): Bad action");
962 switch (flags
->status
)
965 crflag
= O_CREAT
| O_EXCL
;
968 case STATUS_OLD
: /* open will fail if the file does not exist*/
978 crflag
= O_CREAT
| O_TRUNC
;
982 internal_error (&opp
->common
, "regular_file(): Bad status");
985 /* rwflag |= O_LARGEFILE; */
987 #if defined(HAVE_CRLF) && defined(O_BINARY)
991 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
992 fd
= open (path
, rwflag
| crflag
, mode
);
993 if (flags
->action
!= ACTION_UNSPECIFIED
)
998 flags
->action
= ACTION_READWRITE
;
1001 if (errno
!= EACCES
&& errno
!= EROFS
)
1004 /* retry for read-only access */
1006 fd
= open (path
, rwflag
| crflag
, mode
);
1009 flags
->action
= ACTION_READ
;
1010 return fd
; /* success */
1013 if (errno
!= EACCES
)
1014 return fd
; /* failure */
1016 /* retry for write-only access */
1018 fd
= open (path
, rwflag
| crflag
, mode
);
1021 flags
->action
= ACTION_WRITE
;
1022 return fd
; /* success */
1024 return fd
; /* failure */
1028 /* open_external()-- Open an external file, unix specific version.
1029 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1030 * Returns NULL on operating system error. */
1033 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1037 if (flags
->status
== STATUS_SCRATCH
)
1039 fd
= tempfile (opp
);
1040 if (flags
->action
== ACTION_UNSPECIFIED
)
1041 flags
->action
= ACTION_READWRITE
;
1043 #if HAVE_UNLINK_OPEN_FILE
1044 /* We can unlink scratch files now and it will go away when closed. */
1051 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1053 fd
= regular_file (opp
, flags
);
1060 switch (flags
->action
)
1070 case ACTION_READWRITE
:
1071 prot
= PROT_READ
| PROT_WRITE
;
1075 internal_error (&opp
->common
, "open_external(): Bad action");
1078 return fd_to_stream (fd
, prot
);
1082 /* input_stream()-- Return a stream pointer to the default input stream.
1083 * Called on initialization. */
1088 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1092 /* output_stream()-- Return a stream pointer to the default output stream.
1093 * Called on initialization. */
1096 output_stream (void)
1100 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1101 setmode (STDOUT_FILENO
, O_BINARY
);
1104 s
= fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1109 /* error_stream()-- Return a stream pointer to the default error stream.
1110 * Called on initialization. */
1117 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1118 setmode (STDERR_FILENO
, O_BINARY
);
1121 s
= fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1126 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1127 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1128 is big enough to completely fill a 80x25 terminal, so it shuld be
1129 OK. We use a direct write() because it is simpler and least likely
1130 to be clobbered by memory corruption. Writing an error message
1131 longer than that is an error. */
1133 #define ST_VPRINTF_SIZE 2048
1136 st_vprintf (const char *format
, va_list ap
)
1138 static char buffer
[ST_VPRINTF_SIZE
];
1142 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1143 #ifdef HAVE_VSNPRINTF
1144 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1146 written
= vsprintf(buffer
, format
, ap
);
1148 if (written
>= ST_VPRINTF_SIZE
-1)
1150 /* The error message was longer than our buffer. Ouch. Because
1151 we may have messed up things badly, report the error and
1153 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1154 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1155 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1157 #undef ERROR_MESSAGE
1162 written
= write (fd
, buffer
, written
);
1166 /* st_printf()-- printf() function for error output. This just calls
1167 st_vprintf() to do the actual work. */
1170 st_printf (const char *format
, ...)
1174 va_start (ap
, format
);
1175 written
= st_vprintf(format
, ap
);
1181 /* compare_file_filename()-- Given an open stream and a fortran string
1182 * that is a filename, figure out if the file is the same as the
1186 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1188 char path
[PATH_MAX
+ 1];
1190 #ifdef HAVE_WORKING_STAT
1198 if (unpack_filename (path
, name
, len
))
1199 return 0; /* Can't be the same */
1201 /* If the filename doesn't exist, then there is no match with the
1204 if (stat (path
, &st1
) < 0)
1207 #ifdef HAVE_WORKING_STAT
1208 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1209 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1213 /* We try to match files by a unique ID. On some filesystems (network
1214 fs and FAT), we can't generate this unique ID, and will simply compare
1216 id1
= id_from_path (path
);
1217 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1219 return (id1
== id2
);
1222 if (len
!= u
->file_len
)
1224 return (memcmp(path
, u
->file
, len
) == 0);
1229 #ifdef HAVE_WORKING_STAT
1230 # define FIND_FILE0_DECL struct stat *st
1231 # define FIND_FILE0_ARGS st
1233 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1234 # define FIND_FILE0_ARGS id, file, file_len
1237 /* find_file0()-- Recursive work function for find_file() */
1240 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1243 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1250 #ifdef HAVE_WORKING_STAT
1252 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1253 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1257 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1264 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1268 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1272 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1280 /* find_file()-- Take the current filename and see if there is a unit
1281 * that has the file already open. Returns a pointer to the unit if so. */
1284 find_file (const char *file
, gfc_charlen_type file_len
)
1286 char path
[PATH_MAX
+ 1];
1291 if (unpack_filename (path
, file
, file_len
))
1294 if (stat (path
, &st
[0]) < 0)
1297 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1298 id
= id_from_path (path
);
1303 __gthread_mutex_lock (&unit_lock
);
1305 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1309 if (! __gthread_mutex_trylock (&u
->lock
))
1311 /* assert (u->closed == 0); */
1312 __gthread_mutex_unlock (&unit_lock
);
1316 inc_waiting_locked (u
);
1318 __gthread_mutex_unlock (&unit_lock
);
1321 __gthread_mutex_lock (&u
->lock
);
1324 __gthread_mutex_lock (&unit_lock
);
1325 __gthread_mutex_unlock (&u
->lock
);
1326 if (predec_waiting_locked (u
) == 0)
1331 dec_waiting_unlocked (u
);
1337 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1341 if (u
->unit_number
> min_unit
)
1343 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1347 if (u
->unit_number
>= min_unit
)
1349 if (__gthread_mutex_trylock (&u
->lock
))
1353 __gthread_mutex_unlock (&u
->lock
);
1361 flush_all_units (void)
1366 __gthread_mutex_lock (&unit_lock
);
1369 u
= flush_all_units_1 (unit_root
, min_unit
);
1371 inc_waiting_locked (u
);
1372 __gthread_mutex_unlock (&unit_lock
);
1376 __gthread_mutex_lock (&u
->lock
);
1378 min_unit
= u
->unit_number
+ 1;
1383 __gthread_mutex_lock (&unit_lock
);
1384 __gthread_mutex_unlock (&u
->lock
);
1385 (void) predec_waiting_locked (u
);
1389 __gthread_mutex_lock (&unit_lock
);
1390 __gthread_mutex_unlock (&u
->lock
);
1391 if (predec_waiting_locked (u
) == 0)
1399 /* delete_file()-- Given a unit structure, delete the file associated
1400 * with the unit. Returns nonzero if something went wrong. */
1403 delete_file (gfc_unit
* u
)
1405 char path
[PATH_MAX
+ 1];
1407 if (unpack_filename (path
, u
->file
, u
->file_len
))
1408 { /* Shouldn't be possible */
1413 return unlink (path
);
1417 /* file_exists()-- Returns nonzero if the current filename exists on
1421 file_exists (const char *file
, gfc_charlen_type file_len
)
1423 char path
[PATH_MAX
+ 1];
1424 struct stat statbuf
;
1426 if (unpack_filename (path
, file
, file_len
))
1429 if (stat (path
, &statbuf
) < 0)
1437 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1439 /* inquire_sequential()-- Given a fortran string, determine if the
1440 * file is suitable for sequential access. Returns a C-style
1444 inquire_sequential (const char *string
, int len
)
1446 char path
[PATH_MAX
+ 1];
1447 struct stat statbuf
;
1449 if (string
== NULL
||
1450 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1453 if (S_ISREG (statbuf
.st_mode
) ||
1454 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1457 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1464 /* inquire_direct()-- Given a fortran string, determine if the file is
1465 * suitable for direct access. Returns a C-style string. */
1468 inquire_direct (const char *string
, int len
)
1470 char path
[PATH_MAX
+ 1];
1471 struct stat statbuf
;
1473 if (string
== NULL
||
1474 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1477 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1480 if (S_ISDIR (statbuf
.st_mode
) ||
1481 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1488 /* inquire_formatted()-- Given a fortran string, determine if the file
1489 * is suitable for formatted form. Returns a C-style string. */
1492 inquire_formatted (const char *string
, int len
)
1494 char path
[PATH_MAX
+ 1];
1495 struct stat statbuf
;
1497 if (string
== NULL
||
1498 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1501 if (S_ISREG (statbuf
.st_mode
) ||
1502 S_ISBLK (statbuf
.st_mode
) ||
1503 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1506 if (S_ISDIR (statbuf
.st_mode
))
1513 /* inquire_unformatted()-- Given a fortran string, determine if the file
1514 * is suitable for unformatted form. Returns a C-style string. */
1517 inquire_unformatted (const char *string
, int len
)
1519 return inquire_formatted (string
, len
);
1533 /* Fallback implementation of access() on systems that don't have it.
1534 Only modes R_OK and W_OK are used in this file. */
1537 fallback_access (const char *path
, int mode
)
1539 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
1542 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
1549 #define access fallback_access
1553 /* inquire_access()-- Given a fortran string, determine if the file is
1554 * suitable for access. */
1557 inquire_access (const char *string
, int len
, int mode
)
1559 char path
[PATH_MAX
+ 1];
1561 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1562 access (path
, mode
) < 0)
1569 /* inquire_read()-- Given a fortran string, determine if the file is
1570 * suitable for READ access. */
1573 inquire_read (const char *string
, int len
)
1575 return inquire_access (string
, len
, R_OK
);
1579 /* inquire_write()-- Given a fortran string, determine if the file is
1580 * suitable for READ access. */
1583 inquire_write (const char *string
, int len
)
1585 return inquire_access (string
, len
, W_OK
);
1589 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1590 * suitable for read and write access. */
1593 inquire_readwrite (const char *string
, int len
)
1595 return inquire_access (string
, len
, R_OK
| W_OK
);
1599 /* file_length()-- Return the file length in bytes, -1 if unknown */
1602 file_length (stream
* s
)
1605 if (!is_seekable (s
))
1610 end
= sseek (s
, 0, SEEK_END
);
1611 sseek (s
, curr
, SEEK_SET
);
1616 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1620 is_seekable (stream
*s
)
1622 /* By convention, if file_length == -1, the file is not
1624 return ((unix_stream
*) s
)->file_length
!=-1;
1628 /* is_special()-- Return nonzero if the stream is not a regular file. */
1631 is_special (stream
*s
)
1633 return ((unix_stream
*) s
)->special_file
;
1638 stream_isatty (stream
*s
)
1640 return isatty (((unix_stream
*) s
)->fd
);
1644 stream_ttyname (stream
*s
__attribute__ ((unused
)))
1647 return ttyname (((unix_stream
*) s
)->fd
);
1654 /* How files are stored: This is an operating-system specific issue,
1655 and therefore belongs here. There are three cases to consider.
1658 Records are written as block of bytes corresponding to the record
1659 length of the file. This goes for both formatted and unformatted
1660 records. Positioning is done explicitly for each data transfer,
1661 so positioning is not much of an issue.
1663 Sequential Formatted:
1664 Records are separated by newline characters. The newline character
1665 is prohibited from appearing in a string. If it does, this will be
1666 messed up on the next read. End of file is also the end of a record.
1668 Sequential Unformatted:
1669 In this case, we are merely copying bytes to and from main storage,
1670 yet we need to keep track of varying record lengths. We adopt
1671 the solution used by f2c. Each record contains a pair of length
1674 Length of record n in bytes
1676 Length of record n in bytes
1678 Length of record n+1 in bytes
1680 Length of record n+1 in bytes
1682 The length is stored at the end of a record to allow backspacing to the
1683 previous record. Between data transfer statements, the file pointer
1684 is left pointing to the first length of the current record.
1686 ENDFILE records are never explicitly stored.