1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007
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
->file_length
!= -1 && 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
= m
+ n
;
475 n
= s
->len
- s
->active
;
476 if (do_read (s
, s
->buffer
+ s
->active
, &n
) != 0)
479 s
->physical_offset
= m
+ 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 /* Don't increment file_length if the file is non-seekable. */
541 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
542 s
->file_length
= s
->logical_offset
;
544 n
= s
->logical_offset
- s
->buffer_offset
;
548 return s
->buffer
+ where
- s
->buffer_offset
;
553 fd_sfree (unix_stream
* s
)
555 if (s
->ndirty
!= 0 &&
556 (s
->buffer
!= s
->small_buffer
|| options
.all_unbuffered
||
565 fd_seek (unix_stream
* s
, gfc_offset offset
)
568 if (s
->file_length
== -1)
571 if (s
->physical_offset
== offset
) /* Are we lucky and avoid syscall? */
573 s
->logical_offset
= offset
;
577 s
->physical_offset
= s
->logical_offset
= offset
;
580 return (lseek (s
->fd
, offset
, SEEK_SET
) < 0) ? FAILURE
: SUCCESS
;
584 /* truncate_file()-- Given a unit, truncate the file at the current
585 * position. Sets the physical location to the new end of the file.
586 * Returns nonzero on error. */
589 fd_truncate (unix_stream
* s
)
591 /* Non-seekable files, like terminals and fifo's fail the lseek so just
592 return success, there is nothing to truncate. If its not a pipe there
593 is a real problem. */
594 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) == -1)
602 /* Using ftruncate on a seekable special file (like /dev/null)
603 is undefined, so we treat it as if the ftruncate succeeded. */
604 #ifdef HAVE_FTRUNCATE
605 if (s
->special_file
|| ftruncate (s
->fd
, s
->logical_offset
))
608 if (s
->special_file
|| chsize (s
->fd
, s
->logical_offset
))
612 s
->physical_offset
= s
->file_length
= 0;
616 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
622 /* Similar to memset(), but operating on a stream instead of a string.
623 Takes care of not using too much memory. */
626 fd_sset (unix_stream
* s
, int c
, size_t n
)
634 while (bytes_left
> 0)
636 /* memset() in chunks of BUFFER_SIZE. */
637 trans
= (bytes_left
< BUFFER_SIZE
) ? bytes_left
: BUFFER_SIZE
;
639 p
= fd_alloc_w_at (s
, &trans
, -1);
641 memset (p
, c
, trans
);
652 /* Stream read function. Avoids using a buffer for big reads. The
653 interface is like POSIX read(), but the nbytes argument is a
654 pointer; on return it contains the number of bytes written. The
655 function return value is the status indicator (0 for success). */
658 fd_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
663 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
666 p
= fd_alloc_r_at (s
, &tmp
, -1);
670 memcpy (buf
, p
, *nbytes
);
680 /* If the request is bigger than BUFFER_SIZE we flush the buffers
681 and read directly. */
682 if (fd_flush (s
) == FAILURE
)
688 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
694 status
= do_read (s
, buf
, nbytes
);
695 reset_stream (s
, *nbytes
);
700 /* Stream write function. Avoids using a buffer for big writes. The
701 interface is like POSIX write(), but the nbytes argument is a
702 pointer; on return it contains the number of bytes written. The
703 function return value is the status indicator (0 for success). */
706 fd_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
711 if (*nbytes
< BUFFER_SIZE
&& !s
->unbuffered
)
714 p
= fd_alloc_w_at (s
, &tmp
, -1);
718 memcpy (p
, buf
, *nbytes
);
728 /* If the request is bigger than BUFFER_SIZE we flush the buffers
729 and write directly. */
730 if (fd_flush (s
) == FAILURE
)
736 if (is_seekable ((stream
*) s
) && fd_seek (s
, s
->logical_offset
) == FAILURE
)
742 status
= do_write (s
, buf
, nbytes
);
743 reset_stream (s
, *nbytes
);
749 fd_close (unix_stream
* s
)
751 if (fd_flush (s
) == FAILURE
)
754 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
755 free_mem (s
->buffer
);
757 if (s
->fd
!= STDOUT_FILENO
&& s
->fd
!= STDERR_FILENO
)
759 if (close (s
->fd
) < 0)
770 fd_open (unix_stream
* s
)
775 s
->st
.alloc_r_at
= (void *) fd_alloc_r_at
;
776 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
777 s
->st
.sfree
= (void *) fd_sfree
;
778 s
->st
.close
= (void *) fd_close
;
779 s
->st
.seek
= (void *) fd_seek
;
780 s
->st
.truncate
= (void *) fd_truncate
;
781 s
->st
.read
= (void *) fd_read
;
782 s
->st
.write
= (void *) fd_write
;
783 s
->st
.set
= (void *) fd_sset
;
791 /*********************************************************************
792 memory stream functions - These are used for internal files
794 The idea here is that a single stream structure is created and all
795 requests must be satisfied from it. The location and size of the
796 buffer is the character variable supplied to the READ or WRITE
799 *********************************************************************/
803 mem_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
808 where
= s
->logical_offset
;
810 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
813 s
->logical_offset
= where
+ *len
;
815 n
= s
->buffer_offset
+ s
->active
- where
;
819 return s
->buffer
+ (where
- s
->buffer_offset
);
824 mem_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
828 assert (*len
>= 0); /* Negative values not allowed. */
831 where
= s
->logical_offset
;
835 if (where
< s
->buffer_offset
)
838 if (m
> s
->file_length
)
841 s
->logical_offset
= m
;
843 return s
->buffer
+ (where
- s
->buffer_offset
);
847 /* Stream read function for internal units. This is not actually used
848 at the moment, as all internal IO is formatted and the formatted IO
849 routines use mem_alloc_r_at. */
852 mem_read (unix_stream
* s
, void * buf
, size_t * nbytes
)
858 p
= mem_alloc_r_at (s
, &tmp
, -1);
862 memcpy (buf
, p
, *nbytes
);
873 /* Stream write function for internal units. This is not actually used
874 at the moment, as all internal IO is formatted and the formatted IO
875 routines use mem_alloc_w_at. */
878 mem_write (unix_stream
* s
, const void * buf
, size_t * nbytes
)
886 p
= mem_alloc_w_at (s
, &tmp
, -1);
890 memcpy (p
, buf
, *nbytes
);
902 mem_seek (unix_stream
* s
, gfc_offset offset
)
904 if (offset
> s
->file_length
)
910 s
->logical_offset
= offset
;
916 mem_set (unix_stream
* s
, int c
, size_t n
)
923 p
= mem_alloc_w_at (s
, &len
, -1);
935 mem_truncate (unix_stream
* s
__attribute__ ((unused
)))
942 mem_close (unix_stream
* s
)
952 mem_sfree (unix_stream
* s
__attribute__ ((unused
)))
959 /*********************************************************************
960 Public functions -- A reimplementation of this module needs to
961 define functional equivalents of the following.
962 *********************************************************************/
964 /* empty_internal_buffer()-- Zero the buffer of Internal file */
967 empty_internal_buffer(stream
*strm
)
969 unix_stream
* s
= (unix_stream
*) strm
;
970 memset(s
->buffer
, ' ', s
->file_length
);
973 /* open_internal()-- Returns a stream structure from an internal file */
976 open_internal (char *base
, int length
)
980 s
= get_mem (sizeof (unix_stream
));
981 memset (s
, '\0', sizeof (unix_stream
));
984 s
->buffer_offset
= 0;
986 s
->logical_offset
= 0;
987 s
->active
= s
->file_length
= length
;
989 s
->st
.alloc_r_at
= (void *) mem_alloc_r_at
;
990 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
991 s
->st
.sfree
= (void *) mem_sfree
;
992 s
->st
.close
= (void *) mem_close
;
993 s
->st
.seek
= (void *) mem_seek
;
994 s
->st
.truncate
= (void *) mem_truncate
;
995 s
->st
.read
= (void *) mem_read
;
996 s
->st
.write
= (void *) mem_write
;
997 s
->st
.set
= (void *) mem_set
;
1003 /* fd_to_stream()-- Given an open file descriptor, build a stream
1007 fd_to_stream (int fd
, int prot
)
1009 struct stat statbuf
;
1012 s
= get_mem (sizeof (unix_stream
));
1013 memset (s
, '\0', sizeof (unix_stream
));
1016 s
->buffer_offset
= 0;
1017 s
->physical_offset
= 0;
1018 s
->logical_offset
= 0;
1021 /* Get the current length of the file. */
1023 fstat (fd
, &statbuf
);
1025 if (lseek (fd
, 0, SEEK_CUR
) == (off_t
) -1)
1026 s
->file_length
= -1;
1028 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
1030 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
1034 return (stream
*) s
;
1038 /* Given the Fortran unit number, convert it to a C file descriptor. */
1041 unit_to_fd (int unit
)
1046 us
= find_unit (unit
);
1050 fd
= ((unix_stream
*) us
->s
)->fd
;
1056 /* unpack_filename()-- Given a fortran string and a pointer to a
1057 * buffer that is PATH_MAX characters, convert the fortran string to a
1058 * C string in the buffer. Returns nonzero if this is not possible. */
1061 unpack_filename (char *cstring
, const char *fstring
, int len
)
1063 len
= fstrlen (fstring
, len
);
1064 if (len
>= PATH_MAX
)
1067 memmove (cstring
, fstring
, len
);
1068 cstring
[len
] = '\0';
1074 /* tempfile()-- Generate a temporary filename for a scratch file and
1075 * open it. mkstemp() opens the file for reading and writing, but the
1076 * library mode prevents anything that is not allowed. The descriptor
1077 * is returned, which is -1 on error. The template is pointed to by
1078 * opp->file, which is copied into the unit structure
1079 * and freed later. */
1082 tempfile (st_parameter_open
*opp
)
1084 const char *tempdir
;
1088 tempdir
= getenv ("GFORTRAN_TMPDIR");
1089 if (tempdir
== NULL
)
1090 tempdir
= getenv ("TMP");
1091 if (tempdir
== NULL
)
1092 tempdir
= getenv ("TEMP");
1093 if (tempdir
== NULL
)
1094 tempdir
= DEFAULT_TEMPDIR
;
1096 template = get_mem (strlen (tempdir
) + 20);
1098 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
1102 fd
= mkstemp (template);
1104 #else /* HAVE_MKSTEMP */
1106 if (mktemp (template))
1108 #if defined(HAVE_CRLF) && defined(O_BINARY)
1109 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1110 S_IREAD
| S_IWRITE
);
1112 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1114 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
1118 #endif /* HAVE_MKSTEMP */
1121 free_mem (template);
1124 opp
->file
= template;
1125 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1132 /* regular_file()-- Open a regular file.
1133 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1134 * unless an error occurs.
1135 * Returns the descriptor, which is less than zero on error. */
1138 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1140 char path
[PATH_MAX
+ 1];
1146 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1148 errno
= ENOENT
; /* Fake an OS error */
1154 switch (flags
->action
)
1164 case ACTION_READWRITE
:
1165 case ACTION_UNSPECIFIED
:
1170 internal_error (&opp
->common
, "regular_file(): Bad action");
1173 switch (flags
->status
)
1176 crflag
= O_CREAT
| O_EXCL
;
1179 case STATUS_OLD
: /* open will fail if the file does not exist*/
1183 case STATUS_UNKNOWN
:
1184 case STATUS_SCRATCH
:
1188 case STATUS_REPLACE
:
1189 crflag
= O_CREAT
| O_TRUNC
;
1193 internal_error (&opp
->common
, "regular_file(): Bad status");
1196 /* rwflag |= O_LARGEFILE; */
1198 #if defined(HAVE_CRLF) && defined(O_BINARY)
1202 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1203 fd
= open (path
, rwflag
| crflag
, mode
);
1204 if (flags
->action
!= ACTION_UNSPECIFIED
)
1209 flags
->action
= ACTION_READWRITE
;
1212 if (errno
!= EACCES
&& errno
!= EROFS
)
1215 /* retry for read-only access */
1217 fd
= open (path
, rwflag
| crflag
, mode
);
1220 flags
->action
= ACTION_READ
;
1221 return fd
; /* success */
1224 if (errno
!= EACCES
)
1225 return fd
; /* failure */
1227 /* retry for write-only access */
1229 fd
= open (path
, rwflag
| crflag
, mode
);
1232 flags
->action
= ACTION_WRITE
;
1233 return fd
; /* success */
1235 return fd
; /* failure */
1239 /* open_external()-- Open an external file, unix specific version.
1240 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1241 * Returns NULL on operating system error. */
1244 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1248 if (flags
->status
== STATUS_SCRATCH
)
1250 fd
= tempfile (opp
);
1251 if (flags
->action
== ACTION_UNSPECIFIED
)
1252 flags
->action
= ACTION_READWRITE
;
1254 #if HAVE_UNLINK_OPEN_FILE
1255 /* We can unlink scratch files now and it will go away when closed. */
1262 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1264 fd
= regular_file (opp
, flags
);
1271 switch (flags
->action
)
1281 case ACTION_READWRITE
:
1282 prot
= PROT_READ
| PROT_WRITE
;
1286 internal_error (&opp
->common
, "open_external(): Bad action");
1289 return fd_to_stream (fd
, prot
);
1293 /* input_stream()-- Return a stream pointer to the default input stream.
1294 * Called on initialization. */
1299 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1303 /* output_stream()-- Return a stream pointer to the default output stream.
1304 * Called on initialization. */
1307 output_stream (void)
1309 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1310 setmode (STDOUT_FILENO
, O_BINARY
);
1312 return fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1316 /* error_stream()-- Return a stream pointer to the default error stream.
1317 * Called on initialization. */
1322 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1323 setmode (STDERR_FILENO
, O_BINARY
);
1325 return fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1328 /* init_error_stream()-- Return a pointer to the error stream. This
1329 * subroutine is called when the stream is needed, rather than at
1330 * initialization. We want to work even if memory has been seriously
1334 init_error_stream (unix_stream
*error
)
1336 memset (error
, '\0', sizeof (*error
));
1338 error
->fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1340 error
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
1341 error
->st
.sfree
= (void *) fd_sfree
;
1343 error
->unbuffered
= 1;
1344 error
->buffer
= error
->small_buffer
;
1346 return (stream
*) error
;
1350 /* compare_file_filename()-- Given an open stream and a fortran string
1351 * that is a filename, figure out if the file is the same as the
1355 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1357 char path
[PATH_MAX
+ 1];
1359 #ifdef HAVE_WORKING_STAT
1363 if (unpack_filename (path
, name
, len
))
1364 return 0; /* Can't be the same */
1366 /* If the filename doesn't exist, then there is no match with the
1369 if (stat (path
, &st1
) < 0)
1372 #ifdef HAVE_WORKING_STAT
1373 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1374 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1376 if (len
!= u
->file_len
)
1378 return (memcmp(path
, u
->file
, len
) == 0);
1383 #ifdef HAVE_WORKING_STAT
1384 # define FIND_FILE0_DECL struct stat *st
1385 # define FIND_FILE0_ARGS st
1387 # define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
1388 # define FIND_FILE0_ARGS file, file_len
1391 /* find_file0()-- Recursive work function for find_file() */
1394 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1401 #ifdef HAVE_WORKING_STAT
1403 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1404 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1407 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1411 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1415 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1423 /* find_file()-- Take the current filename and see if there is a unit
1424 * that has the file already open. Returns a pointer to the unit if so. */
1427 find_file (const char *file
, gfc_charlen_type file_len
)
1429 char path
[PATH_MAX
+ 1];
1433 if (unpack_filename (path
, file
, file_len
))
1436 if (stat (path
, &st
[0]) < 0)
1439 __gthread_mutex_lock (&unit_lock
);
1441 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1445 if (! __gthread_mutex_trylock (&u
->lock
))
1447 /* assert (u->closed == 0); */
1448 __gthread_mutex_unlock (&unit_lock
);
1452 inc_waiting_locked (u
);
1454 __gthread_mutex_unlock (&unit_lock
);
1457 __gthread_mutex_lock (&u
->lock
);
1460 __gthread_mutex_lock (&unit_lock
);
1461 __gthread_mutex_unlock (&u
->lock
);
1462 if (predec_waiting_locked (u
) == 0)
1467 dec_waiting_unlocked (u
);
1473 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1477 if (u
->unit_number
> min_unit
)
1479 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1483 if (u
->unit_number
>= min_unit
)
1485 if (__gthread_mutex_trylock (&u
->lock
))
1489 __gthread_mutex_unlock (&u
->lock
);
1497 flush_all_units (void)
1502 __gthread_mutex_lock (&unit_lock
);
1505 u
= flush_all_units_1 (unit_root
, min_unit
);
1507 inc_waiting_locked (u
);
1508 __gthread_mutex_unlock (&unit_lock
);
1512 __gthread_mutex_lock (&u
->lock
);
1514 min_unit
= u
->unit_number
+ 1;
1519 __gthread_mutex_lock (&unit_lock
);
1520 __gthread_mutex_unlock (&u
->lock
);
1521 (void) predec_waiting_locked (u
);
1525 __gthread_mutex_lock (&unit_lock
);
1526 __gthread_mutex_unlock (&u
->lock
);
1527 if (predec_waiting_locked (u
) == 0)
1535 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1539 stream_at_bof (stream
* s
)
1543 if (!is_seekable (s
))
1546 us
= (unix_stream
*) s
;
1548 return us
->logical_offset
== 0;
1552 /* stream_at_eof()-- Returns nonzero if the stream is at the end
1556 stream_at_eof (stream
* s
)
1560 if (!is_seekable (s
))
1563 us
= (unix_stream
*) s
;
1565 return us
->logical_offset
== us
->dirty_offset
;
1569 /* delete_file()-- Given a unit structure, delete the file associated
1570 * with the unit. Returns nonzero if something went wrong. */
1573 delete_file (gfc_unit
* u
)
1575 char path
[PATH_MAX
+ 1];
1577 if (unpack_filename (path
, u
->file
, u
->file_len
))
1578 { /* Shouldn't be possible */
1583 return unlink (path
);
1587 /* file_exists()-- Returns nonzero if the current filename exists on
1591 file_exists (const char *file
, gfc_charlen_type file_len
)
1593 char path
[PATH_MAX
+ 1];
1594 struct stat statbuf
;
1596 if (unpack_filename (path
, file
, file_len
))
1599 if (stat (path
, &statbuf
) < 0)
1607 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1609 /* inquire_sequential()-- Given a fortran string, determine if the
1610 * file is suitable for sequential access. Returns a C-style
1614 inquire_sequential (const char *string
, int len
)
1616 char path
[PATH_MAX
+ 1];
1617 struct stat statbuf
;
1619 if (string
== NULL
||
1620 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1623 if (S_ISREG (statbuf
.st_mode
) ||
1624 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1627 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1634 /* inquire_direct()-- Given a fortran string, determine if the file is
1635 * suitable for direct access. Returns a C-style string. */
1638 inquire_direct (const char *string
, int len
)
1640 char path
[PATH_MAX
+ 1];
1641 struct stat statbuf
;
1643 if (string
== NULL
||
1644 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1647 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1650 if (S_ISDIR (statbuf
.st_mode
) ||
1651 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1658 /* inquire_formatted()-- Given a fortran string, determine if the file
1659 * is suitable for formatted form. Returns a C-style string. */
1662 inquire_formatted (const char *string
, int len
)
1664 char path
[PATH_MAX
+ 1];
1665 struct stat statbuf
;
1667 if (string
== NULL
||
1668 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1671 if (S_ISREG (statbuf
.st_mode
) ||
1672 S_ISBLK (statbuf
.st_mode
) ||
1673 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1676 if (S_ISDIR (statbuf
.st_mode
))
1683 /* inquire_unformatted()-- Given a fortran string, determine if the file
1684 * is suitable for unformatted form. Returns a C-style string. */
1687 inquire_unformatted (const char *string
, int len
)
1689 return inquire_formatted (string
, len
);
1693 /* inquire_access()-- Given a fortran string, determine if the file is
1694 * suitable for access. */
1697 inquire_access (const char *string
, int len
, int mode
)
1699 char path
[PATH_MAX
+ 1];
1701 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1702 access (path
, mode
) < 0)
1709 /* inquire_read()-- Given a fortran string, determine if the file is
1710 * suitable for READ access. */
1713 inquire_read (const char *string
, int len
)
1715 return inquire_access (string
, len
, R_OK
);
1719 /* inquire_write()-- Given a fortran string, determine if the file is
1720 * suitable for READ access. */
1723 inquire_write (const char *string
, int len
)
1725 return inquire_access (string
, len
, W_OK
);
1729 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1730 * suitable for read and write access. */
1733 inquire_readwrite (const char *string
, int len
)
1735 return inquire_access (string
, len
, R_OK
| W_OK
);
1739 /* file_length()-- Return the file length in bytes, -1 if unknown */
1742 file_length (stream
* s
)
1744 return ((unix_stream
*) s
)->file_length
;
1748 /* file_position()-- Return the current position of the file */
1751 file_position (stream
* s
)
1753 return ((unix_stream
*) s
)->logical_offset
;
1757 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1761 is_seekable (stream
* s
)
1763 /* By convention, if file_length == -1, the file is not
1765 return ((unix_stream
*) s
)->file_length
!=-1;
1771 return fd_flush( (unix_stream
*) s
);
1775 stream_isatty (stream
*s
)
1777 return isatty (((unix_stream
*) s
)->fd
);
1781 stream_ttyname (stream
*s
)
1784 return ttyname (((unix_stream
*) s
)->fd
);
1791 stream_offset (stream
*s
)
1793 return (((unix_stream
*) s
)->logical_offset
);
1797 /* How files are stored: This is an operating-system specific issue,
1798 and therefore belongs here. There are three cases to consider.
1801 Records are written as block of bytes corresponding to the record
1802 length of the file. This goes for both formatted and unformatted
1803 records. Positioning is done explicitly for each data transfer,
1804 so positioning is not much of an issue.
1806 Sequential Formatted:
1807 Records are separated by newline characters. The newline character
1808 is prohibited from appearing in a string. If it does, this will be
1809 messed up on the next read. End of file is also the end of a record.
1811 Sequential Unformatted:
1812 In this case, we are merely copying bytes to and from main storage,
1813 yet we need to keep track of varying record lengths. We adopt
1814 the solution used by f2c. Each record contains a pair of length
1817 Length of record n in bytes
1819 Length of record n in bytes
1821 Length of record n+1 in bytes
1823 Length of record n+1 in bytes
1825 The length is stored at the end of a record to allow backspacing to the
1826 previous record. Between data transfer statements, the file pointer
1827 is left pointing to the first length of the current record.
1829 ENDFILE records are never explicitly stored.