1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 59 Temple Place - Suite 330,
28 Boston, MA 02111-1307, USA. */
30 /* Unix stream I/O module */
41 #ifdef HAVE_SYS_MMAN_H
47 #include "libgfortran.h"
55 #define MAP_FAILED ((void *) -1)
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 #define BUFFER_SIZE 8192
127 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
128 gfc_offset physical_offset
; /* Current physical file offset */
129 gfc_offset logical_offset
; /* Current logical file offset */
130 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
131 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
134 int len
; /* Physical length of the current buffer */
135 int active
; /* Length of valid bytes in the buffer */
138 int ndirty
; /* Dirty bytes starting at dirty_offset */
140 unsigned unbuffered
:1, mmaped
:1;
142 char small_buffer
[BUFFER_SIZE
];
147 /*move_pos_offset()-- Move the record pointer right or left
148 *relative to current position */
151 move_pos_offset (stream
* st
, int pos_off
)
153 unix_stream
* str
= (unix_stream
*)st
;
156 str
->active
+= pos_off
;
160 str
->logical_offset
+= pos_off
;
162 if (str
->dirty_offset
+str
->ndirty
> str
->logical_offset
)
164 if (str
->ndirty
+ pos_off
> 0)
165 str
->ndirty
+= pos_off
;
168 str
->dirty_offset
+= pos_off
+ 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. */
189 int input
, output
, error
;
191 input
= output
= error
= 0;
193 /* Unix allocates the lowest descriptors first, so a loop is not
194 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
);
223 /* write()-- Write a buffer to a descriptor, allowing for short writes */
226 writen (int fd
, char *buffer
, int len
)
234 n
= write (fd
, buffer
, len
);
247 /* readn()-- Read bytes into a buffer, allowing for short reads. If
248 * fewer than len bytes are returned, it is because we've hit the end
252 readn (int fd
, char *buffer
, int len
)
260 n
= read (fd
, buffer
, len
);
277 /* get_oserror()-- Get the most recent operating system error. For
278 * unix, this is errno. */
283 return strerror (errno
);
287 /* sys_exit()-- Terminate the program with an exit code */
296 /*********************************************************************
297 File descriptor stream functions
298 *********************************************************************/
300 /* fd_flush()-- Write bytes that need to be written */
303 fd_flush (unix_stream
* s
)
308 if (s
->physical_offset
!= s
->dirty_offset
&&
309 lseek (s
->fd
, s
->dirty_offset
, SEEK_SET
) < 0)
312 if (writen (s
->fd
, s
->buffer
+ (s
->dirty_offset
- s
->buffer_offset
),
316 s
->physical_offset
= s
->dirty_offset
+ s
->ndirty
;
318 /* don't increment file_length if the file is non-seekable */
319 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
320 s
->file_length
= s
->physical_offset
;
327 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
328 * satisfied. This subroutine gets the buffer ready for whatever is
332 fd_alloc (unix_stream
* s
, gfc_offset where
, int *len
)
337 if (*len
<= BUFFER_SIZE
)
339 new_buffer
= s
->small_buffer
;
340 read_len
= BUFFER_SIZE
;
344 new_buffer
= get_mem (*len
);
348 /* Salvage bytes currently within the buffer. This is important for
349 * devices that cannot seek. */
351 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
352 where
<= s
->buffer_offset
+ s
->active
)
355 n
= s
->active
- (where
- s
->buffer_offset
);
356 memmove (new_buffer
, s
->buffer
+ (where
- s
->buffer_offset
), n
);
361 { /* new buffer starts off empty */
365 s
->buffer_offset
= where
;
367 /* free the old buffer if necessary */
369 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
370 free_mem (s
->buffer
);
372 s
->buffer
= new_buffer
;
378 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
379 * we've already buffered the data or we need to load it. Returns
380 * NULL on I/O error. */
383 fd_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
389 where
= s
->logical_offset
;
391 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
392 where
+ *len
<= s
->buffer_offset
+ s
->active
)
395 /* Return a position within the current buffer */
397 s
->logical_offset
= where
+ *len
;
398 return s
->buffer
+ where
- s
->buffer_offset
;
401 fd_alloc (s
, where
, len
);
403 m
= where
+ s
->active
;
405 if (s
->physical_offset
!= m
&& lseek (s
->fd
, m
, SEEK_SET
) < 0)
408 n
= read (s
->fd
, s
->buffer
+ s
->active
, s
->len
- s
->active
);
412 s
->physical_offset
= where
+ n
;
415 if (s
->active
< *len
)
416 *len
= s
->active
; /* Bytes actually available */
418 s
->logical_offset
= where
+ *len
;
424 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
425 * we've already buffered the data or we need to load it. */
428 fd_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
433 where
= s
->logical_offset
;
435 if (s
->buffer
== NULL
|| s
->buffer_offset
> where
||
436 where
+ *len
> s
->buffer_offset
+ s
->len
)
439 if (fd_flush (s
) == FAILURE
)
441 fd_alloc (s
, where
, len
);
444 /* Return a position within the current buffer */
446 || where
> s
->dirty_offset
+ s
->ndirty
447 || s
->dirty_offset
> where
+ *len
)
448 { /* Discontiguous blocks, start with a clean buffer. */
449 /* Flush the buffer. */
452 s
->dirty_offset
= where
;
457 gfc_offset start
; /* Merge with the existing data. */
458 if (where
< s
->dirty_offset
)
461 start
= s
->dirty_offset
;
462 if (where
+ *len
> s
->dirty_offset
+ s
->ndirty
)
463 s
->ndirty
= where
+ *len
- start
;
465 s
->ndirty
= s
->dirty_offset
+ s
->ndirty
- start
;
466 s
->dirty_offset
= start
;
469 s
->logical_offset
= where
+ *len
;
471 if (where
+ *len
> s
->file_length
)
472 s
->file_length
= where
+ *len
;
474 n
= s
->logical_offset
- s
->buffer_offset
;
478 return s
->buffer
+ where
- s
->buffer_offset
;
483 fd_sfree (unix_stream
* s
)
485 if (s
->ndirty
!= 0 &&
486 (s
->buffer
!= s
->small_buffer
|| options
.all_unbuffered
||
495 fd_seek (unix_stream
* s
, gfc_offset offset
)
497 s
->physical_offset
= s
->logical_offset
= offset
;
499 return (lseek (s
->fd
, offset
, SEEK_SET
) < 0) ? FAILURE
: SUCCESS
;
503 /* truncate_file()-- Given a unit, truncate the file at the current
504 * position. Sets the physical location to the new end of the file.
505 * Returns nonzero on error. */
508 fd_truncate (unix_stream
* s
)
510 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) == -1)
513 /* non-seekable files, like terminals and fifo's fail the lseek.
514 the fd is a regular file at this point */
516 #ifdef HAVE_FTRUNCATE
517 if (ftruncate (s
->fd
, s
->logical_offset
))
521 if (chsize (s
->fd
, s
->logical_offset
))
526 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
533 fd_close (unix_stream
* s
)
535 if (fd_flush (s
) == FAILURE
)
538 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
539 free_mem (s
->buffer
);
541 if (close (s
->fd
) < 0)
551 fd_open (unix_stream
* s
)
556 s
->st
.alloc_r_at
= (void *) fd_alloc_r_at
;
557 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
558 s
->st
.sfree
= (void *) fd_sfree
;
559 s
->st
.close
= (void *) fd_close
;
560 s
->st
.seek
= (void *) fd_seek
;
561 s
->st
.truncate
= (void *) fd_truncate
;
567 /*********************************************************************
568 mmap stream functions
570 Because mmap() is not capable of extending a file, we have to keep
571 track of how long the file is. We also have to be able to detect end
572 of file conditions. If there are multiple writers to the file (which
573 can only happen outside the current program), things will get
574 confused. Then again, things will get confused anyway.
576 *********************************************************************/
580 static int page_size
, page_mask
;
582 /* mmap_flush()-- Deletes a memory mapping if something is mapped. */
585 mmap_flush (unix_stream
* s
)
590 if (s
->buffer
== NULL
)
593 if (munmap (s
->buffer
, s
->active
))
603 /* mmap_alloc()-- mmap() a section of the file. The whole section is
604 * guaranteed to be mappable. */
607 mmap_alloc (unix_stream
* s
, gfc_offset where
, int *len
)
613 if (mmap_flush (s
) == FAILURE
)
616 offset
= where
& page_mask
; /* Round down to the next page */
618 length
= ((where
- offset
) & page_mask
) + 2 * page_size
;
620 p
= mmap (NULL
, length
, s
->prot
, MAP_SHARED
, s
->fd
, offset
);
621 if (p
== (char *) MAP_FAILED
)
626 s
->buffer_offset
= offset
;
634 mmap_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
639 where
= s
->logical_offset
;
643 if ((s
->buffer
== NULL
|| s
->buffer_offset
> where
||
644 m
> s
->buffer_offset
+ s
->active
) &&
645 mmap_alloc (s
, where
, len
) == FAILURE
)
648 if (m
> s
->file_length
)
650 *len
= s
->file_length
- s
->logical_offset
;
651 s
->logical_offset
= s
->file_length
;
654 s
->logical_offset
= m
;
656 return s
->buffer
+ (where
- s
->buffer_offset
);
661 mmap_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
664 where
= s
->logical_offset
;
666 /* If we're extending the file, we have to use file descriptor
669 if (where
+ *len
> s
->file_length
)
673 return fd_alloc_w_at (s
, len
, where
);
676 if ((s
->buffer
== NULL
|| s
->buffer_offset
> where
||
677 where
+ *len
> s
->buffer_offset
+ s
->active
||
678 where
< s
->buffer_offset
+ s
->active
) &&
679 mmap_alloc (s
, where
, len
) == FAILURE
)
682 s
->logical_offset
= where
+ *len
;
684 return s
->buffer
+ where
- s
->buffer_offset
;
689 mmap_seek (unix_stream
* s
, gfc_offset offset
)
691 s
->logical_offset
= offset
;
697 mmap_close (unix_stream
* s
)
703 if (close (s
->fd
) < 0)
712 mmap_sfree (unix_stream
* s
)
718 /* mmap_open()-- mmap_specific open. If the particular file cannot be
719 * mmap()-ed, we fall back to the file descriptor functions. */
722 mmap_open (unix_stream
* s
)
727 page_size
= getpagesize ();
730 p
= mmap (0, page_size
, s
->prot
, MAP_SHARED
, s
->fd
, 0);
731 if (p
== (char *) MAP_FAILED
)
737 munmap (p
, page_size
);
746 s
->st
.alloc_r_at
= (void *) mmap_alloc_r_at
;
747 s
->st
.alloc_w_at
= (void *) mmap_alloc_w_at
;
748 s
->st
.sfree
= (void *) mmap_sfree
;
749 s
->st
.close
= (void *) mmap_close
;
750 s
->st
.seek
= (void *) mmap_seek
;
751 s
->st
.truncate
= (void *) fd_truncate
;
753 if (lseek (s
->fd
, s
->file_length
, SEEK_SET
) < 0)
762 /*********************************************************************
763 memory stream functions - These are used for internal files
765 The idea here is that a single stream structure is created and all
766 requests must be satisfied from it. The location and size of the
767 buffer is the character variable supplied to the READ or WRITE
770 *********************************************************************/
774 mem_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
779 where
= s
->logical_offset
;
781 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
784 s
->logical_offset
= where
+ *len
;
786 n
= s
->buffer_offset
+ s
->active
- where
;
790 return s
->buffer
+ (where
- s
->buffer_offset
);
795 mem_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
800 where
= s
->logical_offset
;
804 if (where
< s
->buffer_offset
|| m
> s
->buffer_offset
+ s
->active
)
807 s
->logical_offset
= m
;
809 return s
->buffer
+ (where
- s
->buffer_offset
);
814 mem_seek (unix_stream
* s
, gfc_offset offset
)
816 if (offset
> s
->file_length
)
822 s
->logical_offset
= offset
;
828 mem_truncate (unix_stream
* s
)
835 mem_close (unix_stream
* s
)
844 mem_sfree (unix_stream
* s
)
851 /*********************************************************************
852 Public functions -- A reimplementation of this module needs to
853 define functional equivalents of the following.
854 *********************************************************************/
856 /* empty_internal_buffer()-- Zero the buffer of Internal file */
859 empty_internal_buffer(stream
*strm
)
861 unix_stream
* s
= (unix_stream
*) strm
;
862 memset(s
->buffer
, ' ', s
->file_length
);
865 /* open_internal()-- Returns a stream structure from an internal file */
868 open_internal (char *base
, int length
)
872 s
= get_mem (sizeof (unix_stream
));
875 s
->buffer_offset
= 0;
877 s
->logical_offset
= 0;
878 s
->active
= s
->file_length
= length
;
880 s
->st
.alloc_r_at
= (void *) mem_alloc_r_at
;
881 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
882 s
->st
.sfree
= (void *) mem_sfree
;
883 s
->st
.close
= (void *) mem_close
;
884 s
->st
.seek
= (void *) mem_seek
;
885 s
->st
.truncate
= (void *) mem_truncate
;
891 /* fd_to_stream()-- Given an open file descriptor, build a stream
895 fd_to_stream (int fd
, int prot
, int avoid_mmap
)
900 s
= get_mem (sizeof (unix_stream
));
903 s
->buffer_offset
= 0;
904 s
->physical_offset
= 0;
905 s
->logical_offset
= 0;
908 /* Get the current length of the file. */
910 fstat (fd
, &statbuf
);
911 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
926 /* Given the Fortran unit number, convert it to a C file descriptor. */
933 us
= find_unit(unit
);
937 return ((unix_stream
*) us
->s
)->fd
;
941 /* unpack_filename()-- Given a fortran string and a pointer to a
942 * buffer that is PATH_MAX characters, convert the fortran string to a
943 * C string in the buffer. Returns nonzero if this is not possible. */
946 unpack_filename (char *cstring
, const char *fstring
, int len
)
948 len
= fstrlen (fstring
, len
);
952 memmove (cstring
, fstring
, len
);
959 /* tempfile()-- Generate a temporary filename for a scratch file and
960 * open it. mkstemp() opens the file for reading and writing, but the
961 * library mode prevents anything that is not allowed. The descriptor
962 * is returned, which is -1 on error. The template is pointed to by
963 * ioparm.file, which is copied into the unit structure
964 * and freed later. */
973 tempdir
= getenv ("GFORTRAN_TMPDIR");
975 tempdir
= getenv ("TMP");
977 tempdir
= DEFAULT_TEMPDIR
;
979 template = get_mem (strlen (tempdir
) + 20);
981 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
985 fd
= mkstemp (template);
987 #else /* HAVE_MKSTEMP */
989 if (mktemp (template))
991 fd
= open (template, O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
992 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
996 #endif /* HAVE_MKSTEMP */
1002 ioparm
.file
= template;
1003 ioparm
.file_len
= strlen (template); /* Don't include trailing nul */
1010 /* regular_file()-- Open a regular file.
1011 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1012 * unless an error occurs.
1013 * Returns the descriptor, which is less than zero on error. */
1016 regular_file (unit_flags
*flags
)
1018 char path
[PATH_MAX
+ 1];
1024 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1026 errno
= ENOENT
; /* Fake an OS error */
1032 switch (flags
->action
)
1042 case ACTION_READWRITE
:
1043 case ACTION_UNSPECIFIED
:
1048 internal_error ("regular_file(): Bad action");
1051 switch (flags
->status
)
1054 crflag
= O_CREAT
| O_EXCL
;
1057 case STATUS_OLD
: /* open will fail if the file does not exist*/
1061 case STATUS_UNKNOWN
:
1062 case STATUS_SCRATCH
:
1066 case STATUS_REPLACE
:
1067 crflag
= O_CREAT
| O_TRUNC
;
1071 internal_error ("regular_file(): Bad status");
1074 /* rwflag |= O_LARGEFILE; */
1076 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1077 fd
= open (path
, rwflag
| crflag
, mode
);
1078 if (flags
->action
!= ACTION_UNSPECIFIED
)
1083 flags
->action
= ACTION_READWRITE
;
1086 if (errno
!= EACCES
)
1089 /* retry for read-only access */
1091 fd
= open (path
, rwflag
| crflag
, mode
);
1094 flags
->action
= ACTION_READ
;
1095 return fd
; /* success */
1098 if (errno
!= EACCES
)
1099 return fd
; /* failure */
1101 /* retry for write-only access */
1103 fd
= open (path
, rwflag
| crflag
, mode
);
1106 flags
->action
= ACTION_WRITE
;
1107 return fd
; /* success */
1109 return fd
; /* failure */
1113 /* open_external()-- Open an external file, unix specific version.
1114 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1115 * Returns NULL on operating system error. */
1118 open_external (unit_flags
*flags
)
1122 if (flags
->status
== STATUS_SCRATCH
)
1125 if (flags
->action
== ACTION_UNSPECIFIED
)
1126 flags
->action
= ACTION_READWRITE
;
1127 /* We can unlink scratch files now and it will go away when closed. */
1128 unlink (ioparm
.file
);
1132 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1134 fd
= regular_file (flags
);
1141 switch (flags
->action
)
1151 case ACTION_READWRITE
:
1152 prot
= PROT_READ
| PROT_WRITE
;
1156 internal_error ("open_external(): Bad action");
1159 return fd_to_stream (fd
, prot
, 0);
1163 /* input_stream()-- Return a stream pointer to the default input stream.
1164 * Called on initialization. */
1169 return fd_to_stream (STDIN_FILENO
, PROT_READ
, 1);
1173 /* output_stream()-- Return a stream pointer to the default output stream.
1174 * Called on initialization. */
1177 output_stream (void)
1179 return fd_to_stream (STDOUT_FILENO
, PROT_WRITE
, 1);
1183 /* error_stream()-- Return a stream pointer to the default error stream.
1184 * Called on initialization. */
1189 return fd_to_stream (STDERR_FILENO
, PROT_WRITE
, 1);
1192 /* init_error_stream()-- Return a pointer to the error stream. This
1193 * subroutine is called when the stream is needed, rather than at
1194 * initialization. We want to work even if memory has been seriously
1198 init_error_stream (void)
1200 static unix_stream error
;
1202 memset (&error
, '\0', sizeof (error
));
1204 error
.fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1206 error
.st
.alloc_w_at
= (void *) fd_alloc_w_at
;
1207 error
.st
.sfree
= (void *) fd_sfree
;
1209 error
.unbuffered
= 1;
1210 error
.buffer
= error
.small_buffer
;
1212 return (stream
*) & error
;
1216 /* compare_file_filename()-- Given an open stream and a fortran string
1217 * that is a filename, figure out if the file is the same as the
1221 compare_file_filename (stream
* s
, const char *name
, int len
)
1223 char path
[PATH_MAX
+ 1];
1224 struct stat st1
, st2
;
1226 if (unpack_filename (path
, name
, len
))
1227 return 0; /* Can't be the same */
1229 /* If the filename doesn't exist, then there is no match with the
1232 if (stat (path
, &st1
) < 0)
1235 fstat (((unix_stream
*) s
)->fd
, &st2
);
1237 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1241 /* find_file0()-- Recursive work function for find_file() */
1244 find_file0 (gfc_unit
* u
, struct stat
*st1
)
1252 if (fstat (((unix_stream
*) u
->s
)->fd
, &st2
) >= 0 &&
1253 st1
->st_dev
== st2
.st_dev
&& st1
->st_ino
== st2
.st_ino
)
1256 v
= find_file0 (u
->left
, st1
);
1260 v
= find_file0 (u
->right
, st1
);
1268 /* find_file()-- Take the current filename and see if there is a unit
1269 * that has the file already open. Returns a pointer to the unit if so. */
1274 char path
[PATH_MAX
+ 1];
1275 struct stat statbuf
;
1277 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1280 if (stat (path
, &statbuf
) < 0)
1283 return find_file0 (g
.unit_root
, &statbuf
);
1287 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1291 stream_at_bof (stream
* s
)
1295 us
= (unix_stream
*) s
;
1298 return 0; /* File is not seekable */
1300 return us
->logical_offset
== 0;
1304 /* stream_at_eof()-- Returns nonzero if the stream is at the beginning
1308 stream_at_eof (stream
* s
)
1312 us
= (unix_stream
*) s
;
1315 return 0; /* File is not seekable */
1317 return us
->logical_offset
== us
->dirty_offset
;
1321 /* delete_file()-- Given a unit structure, delete the file associated
1322 * with the unit. Returns nonzero if something went wrong. */
1325 delete_file (gfc_unit
* u
)
1327 char path
[PATH_MAX
+ 1];
1329 if (unpack_filename (path
, u
->file
, u
->file_len
))
1330 { /* Shouldn't be possible */
1335 return unlink (path
);
1339 /* file_exists()-- Returns nonzero if the current filename exists on
1345 char path
[PATH_MAX
+ 1];
1346 struct stat statbuf
;
1348 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1351 if (stat (path
, &statbuf
) < 0)
1359 static const char *yes
= "YES", *no
= "NO", *unknown
= "UNKNOWN";
1361 /* inquire_sequential()-- Given a fortran string, determine if the
1362 * file is suitable for sequential access. Returns a C-style
1366 inquire_sequential (const char *string
, int len
)
1368 char path
[PATH_MAX
+ 1];
1369 struct stat statbuf
;
1371 if (string
== NULL
||
1372 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1375 if (S_ISREG (statbuf
.st_mode
) ||
1376 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1379 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1386 /* inquire_direct()-- Given a fortran string, determine if the file is
1387 * suitable for direct access. Returns a C-style string. */
1390 inquire_direct (const char *string
, int len
)
1392 char path
[PATH_MAX
+ 1];
1393 struct stat statbuf
;
1395 if (string
== NULL
||
1396 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1399 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1402 if (S_ISDIR (statbuf
.st_mode
) ||
1403 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1410 /* inquire_formatted()-- Given a fortran string, determine if the file
1411 * is suitable for formatted form. Returns a C-style string. */
1414 inquire_formatted (const char *string
, int len
)
1416 char path
[PATH_MAX
+ 1];
1417 struct stat statbuf
;
1419 if (string
== NULL
||
1420 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1423 if (S_ISREG (statbuf
.st_mode
) ||
1424 S_ISBLK (statbuf
.st_mode
) ||
1425 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1428 if (S_ISDIR (statbuf
.st_mode
))
1435 /* inquire_unformatted()-- Given a fortran string, determine if the file
1436 * is suitable for unformatted form. Returns a C-style string. */
1439 inquire_unformatted (const char *string
, int len
)
1441 return inquire_formatted (string
, len
);
1445 /* inquire_access()-- Given a fortran string, determine if the file is
1446 * suitable for access. */
1449 inquire_access (const char *string
, int len
, int mode
)
1451 char path
[PATH_MAX
+ 1];
1453 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1454 access (path
, mode
) < 0)
1461 /* inquire_read()-- Given a fortran string, determine if the file is
1462 * suitable for READ access. */
1465 inquire_read (const char *string
, int len
)
1467 return inquire_access (string
, len
, R_OK
);
1471 /* inquire_write()-- Given a fortran string, determine if the file is
1472 * suitable for READ access. */
1475 inquire_write (const char *string
, int len
)
1477 return inquire_access (string
, len
, W_OK
);
1481 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1482 * suitable for read and write access. */
1485 inquire_readwrite (const char *string
, int len
)
1487 return inquire_access (string
, len
, R_OK
| W_OK
);
1491 /* file_length()-- Return the file length in bytes, -1 if unknown */
1494 file_length (stream
* s
)
1496 return ((unix_stream
*) s
)->file_length
;
1500 /* file_position()-- Return the current position of the file */
1503 file_position (stream
* s
)
1505 return ((unix_stream
*) s
)->logical_offset
;
1509 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1513 is_seekable (stream
* s
)
1515 /* by convention, if file_length == -1, the file is not seekable
1516 note that a mmapped file is always seekable, an fd_ file may
1518 return ((unix_stream
*) s
)->file_length
!=-1;
1524 return fd_flush( (unix_stream
*) s
);
1528 /* How files are stored: This is an operating-system specific issue,
1529 and therefore belongs here. There are three cases to consider.
1532 Records are written as block of bytes corresponding to the record
1533 length of the file. This goes for both formatted and unformatted
1534 records. Positioning is done explicitly for each data transfer,
1535 so positioning is not much of an issue.
1537 Sequential Formatted:
1538 Records are separated by newline characters. The newline character
1539 is prohibited from appearing in a string. If it does, this will be
1540 messed up on the next read. End of file is also the end of a record.
1542 Sequential Unformatted:
1543 In this case, we are merely copying bytes to and from main storage,
1544 yet we need to keep track of varying record lengths. We adopt
1545 the solution used by f2c. Each record contains a pair of length
1548 Length of record n in bytes
1550 Length of record n in bytes
1552 Length of record n+1 in bytes
1554 Length of record n+1 in bytes
1556 The length is stored at the end of a record to allow backspacing to the
1557 previous record. Between data transfer statements, the file pointer
1558 is left pointing to the first length of the current record.
1560 ENDFILE records are never explicitly stored.