1 /* Copyright (C) 2002, 2003, 2004, 2005
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 /* Unix stream I/O module */
46 #include "libgfortran.h"
51 #define SSIZE_MAX SHRT_MAX
66 /* These flags aren't defined on all targets (mingw32), so provide them
84 /* This implementation of stream I/O is based on the paper:
86 * "Exploiting the advantages of mapped files for stream I/O",
87 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
88 * USENIX conference", p. 27-42.
90 * It differs in a number of ways from the version described in the
91 * paper. First of all, threads are not an issue during I/O and we
92 * also don't have to worry about having multiple regions, since
93 * fortran's I/O model only allows you to be one place at a time.
95 * On the other hand, we have to be able to writing at the end of a
96 * stream, read from the start of a stream or read and write blocks of
97 * bytes from an arbitrary position. After opening a file, a pointer
98 * to a stream structure is returned, which is used to handle file
99 * accesses until the file is closed.
101 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
102 * pointer to a block of memory that mirror the file at position
103 * 'where' that is 'len' bytes long. The len integer is updated to
104 * reflect how many bytes were actually read. The only reason for a
105 * short read is end of file. The file pointer is updated. The
106 * pointer is valid until the next call to salloc_*.
108 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
109 * a pointer to a block of memory that is updated to reflect the state
110 * of the file. The length of the buffer is always equal to that
111 * requested. The buffer must be completely set by the caller. When
112 * data has been written, the sfree() function must be called to
113 * indicate that the caller is done writing data to the buffer. This
114 * may or may not cause a physical write.
116 * Short forms of these are salloc_r() and salloc_w() which drop the
117 * 'where' parameter and use the current file pointer. */
120 /*move_pos_offset()-- Move the record pointer right or left
121 *relative to current position */
124 move_pos_offset (stream
* st
, int pos_off
)
126 unix_stream
* str
= (unix_stream
*)st
;
129 str
->logical_offset
+= pos_off
;
131 if (str
->dirty_offset
+ str
->ndirty
> str
->logical_offset
)
133 if (str
->ndirty
+ pos_off
> 0)
134 str
->ndirty
+= pos_off
;
137 str
->dirty_offset
+= pos_off
+ pos_off
;
148 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
149 * standard descriptors, returning a non-standard descriptor. If the
150 * user specifies that system errors should go to standard output,
151 * then closes standard output, we don't want the system errors to a
152 * file that has been given file descriptor 1 or 0. We want to send
153 * the error to the invalid descriptor. */
158 int input
, output
, error
;
160 input
= output
= error
= 0;
162 /* Unix allocates the lowest descriptors first, so a loop is not
163 required, but this order is. */
165 if (fd
== STDIN_FILENO
)
170 if (fd
== STDOUT_FILENO
)
175 if (fd
== STDERR_FILENO
)
182 close (STDIN_FILENO
);
184 close (STDOUT_FILENO
);
186 close (STDERR_FILENO
);
192 is_preconnected (stream
* s
)
196 fd
= ((unix_stream
*) s
)->fd
;
197 if (fd
== STDIN_FILENO
|| fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
)
203 /* If the stream corresponds to a preconnected unit, we flush the
204 corresponding C stream. This is bugware for mixed C-Fortran codes
205 where the C code doesn't flush I/O before returning. */
207 flush_if_preconnected (stream
* s
)
211 fd
= ((unix_stream
*) s
)->fd
;
212 if (fd
== STDIN_FILENO
)
214 else if (fd
== STDOUT_FILENO
)
216 else if (fd
== STDERR_FILENO
)
221 /* Reset a stream after reading/writing. Assumes that the buffers have
225 reset_stream (unix_stream
* s
, size_t bytes_rw
)
227 s
->physical_offset
+= bytes_rw
;
228 s
->logical_offset
= s
->physical_offset
;
229 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
230 s
->file_length
= s
->physical_offset
;
234 /* Read bytes into a buffer, allowing for short reads. If the nbytes
235 * argument is less on return than on entry, it is because we've hit
236 * the end of file. */
239 do_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
247 bytes_left
= *nbytes
;
248 buf_st
= (char *) buf
;
250 /* We must read in a loop since some systems don't restart system
251 calls in case of a signal. */
252 while (bytes_left
> 0)
254 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
255 so we must read in chunks smaller than SSIZE_MAX. */
256 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
257 trans
= read (s
->fd
, buf_st
, trans
);
268 else if (trans
== 0) /* We hit EOF. */
274 *nbytes
-= bytes_left
;
279 /* Write a buffer to a stream, allowing for short writes. */
282 do_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
290 bytes_left
= *nbytes
;
291 buf_st
= (char *) buf
;
293 /* We must write in a loop since some systems don't restart system
294 calls in case of a signal. */
295 while (bytes_left
> 0)
297 /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
298 so we must write in chunks smaller than SSIZE_MAX. */
299 trans
= (bytes_left
< SSIZE_MAX
) ? bytes_left
: SSIZE_MAX
;
300 trans
= write (s
->fd
, buf_st
, trans
);
315 *nbytes
-= bytes_left
;
320 /* get_oserror()-- Get the most recent operating system error. For
321 * unix, this is errno. */
326 return strerror (errno
);
330 /* sys_exit()-- Terminate the program with an exit code */
339 /*********************************************************************
340 File descriptor stream functions
341 *********************************************************************/
344 /* fd_flush()-- Write bytes that need to be written */
347 fd_flush (unix_stream
* s
)
354 if (s
->physical_offset
!= s
->dirty_offset
&&
355 lseek (s
->fd
, s
->dirty_offset
, SEEK_SET
) < 0)
358 writelen
= s
->ndirty
;
359 if (do_write (s
, s
->buffer
+ (s
->dirty_offset
- s
->buffer_offset
),
363 s
->physical_offset
= s
->dirty_offset
+ writelen
;
365 /* don't increment file_length if the file is non-seekable */
366 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
367 s
->file_length
= s
->physical_offset
;
369 s
->ndirty
-= writelen
;
377 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
378 * satisfied. This subroutine gets the buffer ready for whatever is
382 fd_alloc (unix_stream
* s
, gfc_offset where
,
383 int *len
__attribute__ ((unused
)))
388 if (*len
<= BUFFER_SIZE
)
390 new_buffer
= s
->small_buffer
;
391 read_len
= BUFFER_SIZE
;
395 new_buffer
= get_mem (*len
);
399 /* Salvage bytes currently within the buffer. This is important for
400 * devices that cannot seek. */
402 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
403 where
<= s
->buffer_offset
+ s
->active
)
406 n
= s
->active
- (where
- s
->buffer_offset
);
407 memmove (new_buffer
, s
->buffer
+ (where
- s
->buffer_offset
), n
);
412 { /* new buffer starts off empty */
416 s
->buffer_offset
= where
;
418 /* free the old buffer if necessary */
420 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
421 free_mem (s
->buffer
);
423 s
->buffer
= new_buffer
;
428 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
429 * we've already buffered the data or we need to load it. Returns
430 * NULL on I/O error. */
433 fd_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
438 where
= s
->logical_offset
;
440 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
441 where
+ *len
<= s
->buffer_offset
+ s
->active
)
444 /* Return a position within the current buffer */
446 s
->logical_offset
= where
+ *len
;
447 return s
->buffer
+ where
- s
->buffer_offset
;
450 fd_alloc (s
, where
, len
);
452 m
= where
+ s
->active
;
454 if (s
->physical_offset
!= m
&& lseek (s
->fd
, m
, SEEK_SET
) < 0)
457 /* do_read() hangs on read from terminals for *BSD-systems. Only
458 use read() in that case. */
464 n
= read (s
->fd
, s
->buffer
+ s
->active
, s
->len
- s
->active
);
468 s
->physical_offset
= where
+ n
;
475 n
= s
->len
- s
->active
;
476 if (do_read (s
, s
->buffer
+ s
->active
, &n
) != 0)
479 s
->physical_offset
= where
+ n
;
483 if (s
->active
< *len
)
484 *len
= s
->active
; /* Bytes actually available */
486 s
->logical_offset
= where
+ *len
;
492 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
493 * we've already buffered the data or we need to load it. */
496 fd_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
501 where
= s
->logical_offset
;
503 if (s
->buffer
== NULL
|| s
->buffer_offset
> where
||
504 where
+ *len
> s
->buffer_offset
+ s
->len
)
507 if (fd_flush (s
) == FAILURE
)
509 fd_alloc (s
, where
, len
);
512 /* Return a position within the current buffer */
514 || where
> s
->dirty_offset
+ s
->ndirty
515 || s
->dirty_offset
> where
+ *len
)
516 { /* Discontiguous blocks, start with a clean buffer. */
517 /* Flush the buffer. */
520 s
->dirty_offset
= where
;
525 gfc_offset start
; /* Merge with the existing data. */
526 if (where
< s
->dirty_offset
)
529 start
= s
->dirty_offset
;
530 if (where
+ *len
> s
->dirty_offset
+ s
->ndirty
)
531 s
->ndirty
= where
+ *len
- start
;
533 s
->ndirty
= s
->dirty_offset
+ s
->ndirty
- start
;
534 s
->dirty_offset
= start
;
537 s
->logical_offset
= where
+ *len
;
539 if (where
+ *len
> s
->file_length
)
540 s
->file_length
= where
+ *len
;
542 n
= s
->logical_offset
- s
->buffer_offset
;
546 return s
->buffer
+ where
- s
->buffer_offset
;
551 fd_sfree (unix_stream
* s
)
553 if (s
->ndirty
!= 0 &&
554 (s
->buffer
!= s
->small_buffer
|| options
.all_unbuffered
||
563 fd_seek (unix_stream
* s
, gfc_offset offset
)
565 s
->logical_offset
= offset
;
571 /* truncate_file()-- Given a unit, truncate the file at the current
572 * position. Sets the physical location to the new end of the file.
573 * Returns nonzero on error. */
576 fd_truncate (unix_stream
* s
)
578 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) == -1)
581 /* non-seekable files, like terminals and fifo's fail the lseek.
582 Using ftruncate on a seekable special file (like /dev/null)
583 is undefined, so we treat it as if the ftruncate failed.
585 #ifdef HAVE_FTRUNCATE
586 if (s
->special_file
|| ftruncate (s
->fd
, s
->logical_offset
))
589 if (s
->special_file
|| chsize (s
->fd
, s
->logical_offset
))
593 s
->physical_offset
= s
->file_length
= 0;
597 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
603 /* Similar to memset(), but operating on a stream instead of a string.
604 Takes care of not using too much memory. */
607 fd_sset (unix_stream
* s
, int c
, size_t n
)
615 while (bytes_left
> 0)
617 /* memset() in chunks of BUFFER_SIZE. */
618 trans
= (bytes_left
< BUFFER_SIZE
) ? bytes_left
: BUFFER_SIZE
;
620 p
= fd_alloc_w_at (s
, &trans
, -1);
622 memset (p
, c
, trans
);
633 /* Stream read function. Avoids using a buffer for big reads. The
634 interface is like POSIX read(), but the nbytes argument is a
635 pointer; on return it contains the number of bytes written. The
636 function return value is the status indicator (0 for success). */
639 fd_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
644 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
647 p
= fd_alloc_r_at (s
, &tmp
, -1);
651 memcpy (buf
, p
, *nbytes
);
661 /* If the request is bigger than BUFFER_SIZE we flush the buffers
662 and read directly. */
663 if (fd_flush (s
) == FAILURE
)
669 if (is_seekable ((stream
*) s
) && s
->physical_offset
!= s
->logical_offset
670 && lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
676 status
= do_read (s
, buf
, nbytes
);
677 reset_stream (s
, *nbytes
);
682 /* Stream write function. Avoids using a buffer for big writes. The
683 interface is like POSIX write(), but the nbytes argument is a
684 pointer; on return it contains the number of bytes written. The
685 function return value is the status indicator (0 for success). */
688 fd_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
693 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
696 p
= fd_alloc_w_at (s
, &tmp
, -1);
700 memcpy (p
, buf
, *nbytes
);
710 /* If the request is bigger than BUFFER_SIZE we flush the buffers
711 and write directly. */
712 if (fd_flush (s
) == FAILURE
)
718 if (is_seekable ((stream
*) s
) && s
->physical_offset
!= s
->logical_offset
719 && lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
725 status
= do_write (s
, buf
, nbytes
);
726 reset_stream (s
, *nbytes
);
732 fd_close (unix_stream
* s
)
734 if (fd_flush (s
) == FAILURE
)
737 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
738 free_mem (s
->buffer
);
740 if (s
->fd
!= STDOUT_FILENO
&& s
->fd
!= STDERR_FILENO
)
742 if (close (s
->fd
) < 0)
753 fd_open (unix_stream
* s
)
758 s
->st
.alloc_r_at
= (void *) fd_alloc_r_at
;
759 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
760 s
->st
.sfree
= (void *) fd_sfree
;
761 s
->st
.close
= (void *) fd_close
;
762 s
->st
.seek
= (void *) fd_seek
;
763 s
->st
.truncate
= (void *) fd_truncate
;
764 s
->st
.read
= (void *) fd_read
;
765 s
->st
.write
= (void *) fd_write
;
766 s
->st
.set
= (void *) fd_sset
;
774 /*********************************************************************
775 memory stream functions - These are used for internal files
777 The idea here is that a single stream structure is created and all
778 requests must be satisfied from it. The location and size of the
779 buffer is the character variable supplied to the READ or WRITE
782 *********************************************************************/
786 mem_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
791 where
= s
->logical_offset
;
793 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
796 s
->logical_offset
= where
+ *len
;
798 n
= s
->buffer_offset
+ s
->active
- where
;
802 return s
->buffer
+ (where
- s
->buffer_offset
);
807 mem_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
811 assert (*len
>= 0); /* Negative values not allowed. */
814 where
= s
->logical_offset
;
818 if (where
< s
->buffer_offset
)
821 if (m
> s
->file_length
)
824 s
->logical_offset
= m
;
826 return s
->buffer
+ (where
- s
->buffer_offset
);
830 /* Stream read function for internal units. This is not actually used
831 at the moment, as all internal IO is formatted and the formatted IO
832 routines use mem_alloc_r_at. */
835 mem_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
841 p
= mem_alloc_r_at (s
, &tmp
, -1);
845 memcpy (buf
, p
, *nbytes
);
856 /* Stream write function for internal units. This is not actually used
857 at the moment, as all internal IO is formatted and the formatted IO
858 routines use mem_alloc_w_at. */
861 mem_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
869 p
= mem_alloc_w_at (s
, &tmp
, -1);
873 memcpy (p
, buf
, *nbytes
);
885 mem_seek (unix_stream
* s
, gfc_offset offset
)
887 if (offset
> s
->file_length
)
893 s
->logical_offset
= offset
;
899 mem_set (unix_stream
* s
, int c
, size_t n
)
906 p
= mem_alloc_w_at (s
, &len
, -1);
918 mem_truncate (unix_stream
* s
__attribute__ ((unused
)))
925 mem_close (unix_stream
* s
)
934 mem_sfree (unix_stream
* s
__attribute__ ((unused
)))
941 /*********************************************************************
942 Public functions -- A reimplementation of this module needs to
943 define functional equivalents of the following.
944 *********************************************************************/
946 /* empty_internal_buffer()-- Zero the buffer of Internal file */
949 empty_internal_buffer(stream
*strm
)
951 unix_stream
* s
= (unix_stream
*) strm
;
952 memset(s
->buffer
, ' ', s
->file_length
);
955 /* open_internal()-- Returns a stream structure from an internal file */
958 open_internal (char *base
, int length
)
962 s
= get_mem (sizeof (unix_stream
));
963 memset (s
, '\0', sizeof (unix_stream
));
966 s
->buffer_offset
= 0;
968 s
->logical_offset
= 0;
969 s
->active
= s
->file_length
= length
;
971 s
->st
.alloc_r_at
= (void *) mem_alloc_r_at
;
972 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
973 s
->st
.sfree
= (void *) mem_sfree
;
974 s
->st
.close
= (void *) mem_close
;
975 s
->st
.seek
= (void *) mem_seek
;
976 s
->st
.truncate
= (void *) mem_truncate
;
977 s
->st
.read
= (void *) mem_read
;
978 s
->st
.write
= (void *) mem_write
;
979 s
->st
.set
= (void *) mem_set
;
985 /* fd_to_stream()-- Given an open file descriptor, build a stream
989 fd_to_stream (int fd
, int prot
)
994 s
= get_mem (sizeof (unix_stream
));
995 memset (s
, '\0', sizeof (unix_stream
));
998 s
->buffer_offset
= 0;
999 s
->physical_offset
= 0;
1000 s
->logical_offset
= 0;
1003 /* Get the current length of the file. */
1005 fstat (fd
, &statbuf
);
1006 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
1007 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
1011 return (stream
*) s
;
1015 /* Given the Fortran unit number, convert it to a C file descriptor. */
1018 unit_to_fd (int unit
)
1023 us
= find_unit (unit
);
1027 fd
= ((unix_stream
*) us
->s
)->fd
;
1033 /* unpack_filename()-- Given a fortran string and a pointer to a
1034 * buffer that is PATH_MAX characters, convert the fortran string to a
1035 * C string in the buffer. Returns nonzero if this is not possible. */
1038 unpack_filename (char *cstring
, const char *fstring
, int len
)
1040 len
= fstrlen (fstring
, len
);
1041 if (len
>= PATH_MAX
)
1044 memmove (cstring
, fstring
, len
);
1045 cstring
[len
] = '\0';
1051 /* tempfile()-- Generate a temporary filename for a scratch file and
1052 * open it. mkstemp() opens the file for reading and writing, but the
1053 * library mode prevents anything that is not allowed. The descriptor
1054 * is returned, which is -1 on error. The template is pointed to by
1055 * opp->file, which is copied into the unit structure
1056 * and freed later. */
1059 tempfile (st_parameter_open
*opp
)
1061 const char *tempdir
;
1065 tempdir
= getenv ("GFORTRAN_TMPDIR");
1066 if (tempdir
== NULL
)
1067 tempdir
= getenv ("TMP");
1068 if (tempdir
== NULL
)
1069 tempdir
= getenv ("TEMP");
1070 if (tempdir
== NULL
)
1071 tempdir
= DEFAULT_TEMPDIR
;
1073 template = get_mem (strlen (tempdir
) + 20);
1075 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
1079 fd
= mkstemp (template);
1081 #else /* HAVE_MKSTEMP */
1083 if (mktemp (template))
1085 #if defined(HAVE_CRLF) && defined(O_BINARY)
1086 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1087 S_IREAD
| S_IWRITE
);
1089 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1091 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
1095 #endif /* HAVE_MKSTEMP */
1098 free_mem (template);
1101 opp
->file
= template;
1102 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1109 /* regular_file()-- Open a regular file.
1110 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1111 * unless an error occurs.
1112 * Returns the descriptor, which is less than zero on error. */
1115 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1117 char path
[PATH_MAX
+ 1];
1123 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1125 errno
= ENOENT
; /* Fake an OS error */
1131 switch (flags
->action
)
1141 case ACTION_READWRITE
:
1142 case ACTION_UNSPECIFIED
:
1147 internal_error (&opp
->common
, "regular_file(): Bad action");
1150 switch (flags
->status
)
1153 crflag
= O_CREAT
| O_EXCL
;
1156 case STATUS_OLD
: /* open will fail if the file does not exist*/
1160 case STATUS_UNKNOWN
:
1161 case STATUS_SCRATCH
:
1165 case STATUS_REPLACE
:
1166 crflag
= O_CREAT
| O_TRUNC
;
1170 internal_error (&opp
->common
, "regular_file(): Bad status");
1173 /* rwflag |= O_LARGEFILE; */
1175 #if defined(HAVE_CRLF) && defined(O_BINARY)
1179 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1180 fd
= open (path
, rwflag
| crflag
, mode
);
1181 if (flags
->action
!= ACTION_UNSPECIFIED
)
1186 flags
->action
= ACTION_READWRITE
;
1189 if (errno
!= EACCES
)
1192 /* retry for read-only access */
1194 fd
= open (path
, rwflag
| crflag
, mode
);
1197 flags
->action
= ACTION_READ
;
1198 return fd
; /* success */
1201 if (errno
!= EACCES
)
1202 return fd
; /* failure */
1204 /* retry for write-only access */
1206 fd
= open (path
, rwflag
| crflag
, mode
);
1209 flags
->action
= ACTION_WRITE
;
1210 return fd
; /* success */
1212 return fd
; /* failure */
1216 /* open_external()-- Open an external file, unix specific version.
1217 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1218 * Returns NULL on operating system error. */
1221 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1225 if (flags
->status
== STATUS_SCRATCH
)
1227 fd
= tempfile (opp
);
1228 if (flags
->action
== ACTION_UNSPECIFIED
)
1229 flags
->action
= ACTION_READWRITE
;
1231 #if HAVE_UNLINK_OPEN_FILE
1232 /* We can unlink scratch files now and it will go away when closed. */
1239 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1241 fd
= regular_file (opp
, flags
);
1248 switch (flags
->action
)
1258 case ACTION_READWRITE
:
1259 prot
= PROT_READ
| PROT_WRITE
;
1263 internal_error (&opp
->common
, "open_external(): Bad action");
1266 return fd_to_stream (fd
, prot
);
1270 /* input_stream()-- Return a stream pointer to the default input stream.
1271 * Called on initialization. */
1276 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1280 /* output_stream()-- Return a stream pointer to the default output stream.
1281 * Called on initialization. */
1284 output_stream (void)
1286 return fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1290 /* error_stream()-- Return a stream pointer to the default error stream.
1291 * Called on initialization. */
1296 return fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1299 /* init_error_stream()-- Return a pointer to the error stream. This
1300 * subroutine is called when the stream is needed, rather than at
1301 * initialization. We want to work even if memory has been seriously
1305 init_error_stream (unix_stream
*error
)
1307 memset (error
, '\0', sizeof (*error
));
1309 error
->fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1311 error
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
1312 error
->st
.sfree
= (void *) fd_sfree
;
1314 error
->unbuffered
= 1;
1315 error
->buffer
= error
->small_buffer
;
1317 return (stream
*) error
;
1321 /* compare_file_filename()-- Given an open stream and a fortran string
1322 * that is a filename, figure out if the file is the same as the
1326 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1328 char path
[PATH_MAX
+ 1];
1330 #ifdef HAVE_WORKING_STAT
1334 if (unpack_filename (path
, name
, len
))
1335 return 0; /* Can't be the same */
1337 /* If the filename doesn't exist, then there is no match with the
1340 if (stat (path
, &st1
) < 0)
1343 #ifdef HAVE_WORKING_STAT
1344 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1345 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1347 if (len
!= u
->file_len
)
1349 return (memcmp(path
, u
->file
, len
) == 0);
1354 #ifdef HAVE_WORKING_STAT
1355 # define FIND_FILE0_DECL struct stat *st
1356 # define FIND_FILE0_ARGS st
1358 # define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
1359 # define FIND_FILE0_ARGS file, file_len
1362 /* find_file0()-- Recursive work function for find_file() */
1365 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1372 #ifdef HAVE_WORKING_STAT
1374 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1375 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1378 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1382 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1386 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1394 /* find_file()-- Take the current filename and see if there is a unit
1395 * that has the file already open. Returns a pointer to the unit if so. */
1398 find_file (const char *file
, gfc_charlen_type file_len
)
1400 char path
[PATH_MAX
+ 1];
1404 if (unpack_filename (path
, file
, file_len
))
1407 if (stat (path
, &st
[0]) < 0)
1410 __gthread_mutex_lock (&unit_lock
);
1412 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1416 if (! __gthread_mutex_trylock (&u
->lock
))
1418 /* assert (u->closed == 0); */
1419 __gthread_mutex_unlock (&unit_lock
);
1423 inc_waiting_locked (u
);
1425 __gthread_mutex_unlock (&unit_lock
);
1428 __gthread_mutex_lock (&u
->lock
);
1431 __gthread_mutex_lock (&unit_lock
);
1432 __gthread_mutex_unlock (&u
->lock
);
1433 if (predec_waiting_locked (u
) == 0)
1438 dec_waiting_unlocked (u
);
1444 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1448 if (u
->unit_number
> min_unit
)
1450 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1454 if (u
->unit_number
>= min_unit
)
1456 if (__gthread_mutex_trylock (&u
->lock
))
1460 __gthread_mutex_unlock (&u
->lock
);
1468 flush_all_units (void)
1473 __gthread_mutex_lock (&unit_lock
);
1476 u
= flush_all_units_1 (unit_root
, min_unit
);
1478 inc_waiting_locked (u
);
1479 __gthread_mutex_unlock (&unit_lock
);
1483 __gthread_mutex_lock (&u
->lock
);
1485 min_unit
= u
->unit_number
+ 1;
1490 __gthread_mutex_lock (&unit_lock
);
1491 __gthread_mutex_unlock (&u
->lock
);
1492 (void) predec_waiting_locked (u
);
1496 __gthread_mutex_lock (&unit_lock
);
1497 __gthread_mutex_unlock (&u
->lock
);
1498 if (predec_waiting_locked (u
) == 0)
1506 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1510 stream_at_bof (stream
* s
)
1514 if (!is_seekable (s
))
1517 us
= (unix_stream
*) s
;
1519 return us
->logical_offset
== 0;
1523 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1527 stream_at_eof (stream
* s
)
1531 if (!is_seekable (s
))
1534 us
= (unix_stream
*) s
;
1536 return us
->logical_offset
== us
->dirty_offset
;
1540 /* delete_file()-- Given a unit structure, delete the file associated
1541 * with the unit. Returns nonzero if something went wrong. */
1544 delete_file (gfc_unit
* u
)
1546 char path
[PATH_MAX
+ 1];
1548 if (unpack_filename (path
, u
->file
, u
->file_len
))
1549 { /* Shouldn't be possible */
1554 return unlink (path
);
1558 /* file_exists()-- Returns nonzero if the current filename exists on
1562 file_exists (const char *file
, gfc_charlen_type file_len
)
1564 char path
[PATH_MAX
+ 1];
1565 struct stat statbuf
;
1567 if (unpack_filename (path
, file
, file_len
))
1570 if (stat (path
, &statbuf
) < 0)
1578 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1580 /* inquire_sequential()-- Given a fortran string, determine if the
1581 * file is suitable for sequential access. Returns a C-style
1585 inquire_sequential (const char *string
, int len
)
1587 char path
[PATH_MAX
+ 1];
1588 struct stat statbuf
;
1590 if (string
== NULL
||
1591 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1594 if (S_ISREG (statbuf
.st_mode
) ||
1595 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1598 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1605 /* inquire_direct()-- Given a fortran string, determine if the file is
1606 * suitable for direct access. Returns a C-style string. */
1609 inquire_direct (const char *string
, int len
)
1611 char path
[PATH_MAX
+ 1];
1612 struct stat statbuf
;
1614 if (string
== NULL
||
1615 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1618 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1621 if (S_ISDIR (statbuf
.st_mode
) ||
1622 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1629 /* inquire_formatted()-- Given a fortran string, determine if the file
1630 * is suitable for formatted form. Returns a C-style string. */
1633 inquire_formatted (const char *string
, int len
)
1635 char path
[PATH_MAX
+ 1];
1636 struct stat statbuf
;
1638 if (string
== NULL
||
1639 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1642 if (S_ISREG (statbuf
.st_mode
) ||
1643 S_ISBLK (statbuf
.st_mode
) ||
1644 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1647 if (S_ISDIR (statbuf
.st_mode
))
1654 /* inquire_unformatted()-- Given a fortran string, determine if the file
1655 * is suitable for unformatted form. Returns a C-style string. */
1658 inquire_unformatted (const char *string
, int len
)
1660 return inquire_formatted (string
, len
);
1664 /* inquire_access()-- Given a fortran string, determine if the file is
1665 * suitable for access. */
1668 inquire_access (const char *string
, int len
, int mode
)
1670 char path
[PATH_MAX
+ 1];
1672 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1673 access (path
, mode
) < 0)
1680 /* inquire_read()-- Given a fortran string, determine if the file is
1681 * suitable for READ access. */
1684 inquire_read (const char *string
, int len
)
1686 return inquire_access (string
, len
, R_OK
);
1690 /* inquire_write()-- Given a fortran string, determine if the file is
1691 * suitable for READ access. */
1694 inquire_write (const char *string
, int len
)
1696 return inquire_access (string
, len
, W_OK
);
1700 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1701 * suitable for read and write access. */
1704 inquire_readwrite (const char *string
, int len
)
1706 return inquire_access (string
, len
, R_OK
| W_OK
);
1710 /* file_length()-- Return the file length in bytes, -1 if unknown */
1713 file_length (stream
* s
)
1715 return ((unix_stream
*) s
)->file_length
;
1719 /* file_position()-- Return the current position of the file */
1722 file_position (stream
* s
)
1724 return ((unix_stream
*) s
)->logical_offset
;
1728 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1732 is_seekable (stream
* s
)
1734 /* By convention, if file_length == -1, the file is not
1736 return ((unix_stream
*) s
)->file_length
!=-1;
1742 return fd_flush( (unix_stream
*) s
);
1746 stream_isatty (stream
*s
)
1748 return isatty (((unix_stream
*) s
)->fd
);
1752 stream_ttyname (stream
*s
)
1755 return ttyname (((unix_stream
*) s
)->fd
);
1762 stream_offset (stream
*s
)
1764 return (((unix_stream
*) s
)->logical_offset
);
1768 /* How files are stored: This is an operating-system specific issue,
1769 and therefore belongs here. There are three cases to consider.
1772 Records are written as block of bytes corresponding to the record
1773 length of the file. This goes for both formatted and unformatted
1774 records. Positioning is done explicitly for each data transfer,
1775 so positioning is not much of an issue.
1777 Sequential Formatted:
1778 Records are separated by newline characters. The newline character
1779 is prohibited from appearing in a string. If it does, this will be
1780 messed up on the next read. End of file is also the end of a record.
1782 Sequential Unformatted:
1783 In this case, we are merely copying bytes to and from main storage,
1784 yet we need to keep track of varying record lengths. We adopt
1785 the solution used by f2c. Each record contains a pair of length
1788 Length of record n in bytes
1790 Length of record n in bytes
1792 Length of record n+1 in bytes
1794 Length of record n+1 in bytes
1796 The length is stored at the end of a record to allow backspacing to the
1797 previous record. Between data transfer statements, the file pointer
1798 is left pointing to the first length of the current record.
1800 ENDFILE records are never explicitly stored.