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 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with Libgfortran; see the file COPYING. If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
21 /* Unix stream I/O module */
32 #ifdef HAVE_SYS_MMAN_H
38 #include "libgfortran.h"
46 #define MAP_FAILED ((void *) -1)
57 /* These flags aren't defined on all targets (mingw32), so provide them
75 /* This implementation of stream I/O is based on the paper:
77 * "Exploiting the advantages of mapped files for stream I/O",
78 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
79 * USENIX conference", p. 27-42.
81 * It differs in a number of ways from the version described in the
82 * paper. First of all, threads are not an issue during I/O and we
83 * also don't have to worry about having multiple regions, since
84 * fortran's I/O model only allows you to be one place at a time.
86 * On the other hand, we have to be able to writing at the end of a
87 * stream, read from the start of a stream or read and write blocks of
88 * bytes from an arbitrary position. After opening a file, a pointer
89 * to a stream structure is returned, which is used to handle file
90 * accesses until the file is closed.
92 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
93 * pointer to a block of memory that mirror the file at position
94 * 'where' that is 'len' bytes long. The len integer is updated to
95 * reflect how many bytes were actually read. The only reason for a
96 * short read is end of file. The file pointer is updated. The
97 * pointer is valid until the next call to salloc_*.
99 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
100 * a pointer to a block of memory that is updated to reflect the state
101 * of the file. The length of the buffer is always equal to that
102 * requested. The buffer must be completely set by the caller. When
103 * data has been written, the sfree() function must be called to
104 * indicate that the caller is done writing data to the buffer. This
105 * may or may not cause a physical write.
107 * Short forms of these are salloc_r() and salloc_w() which drop the
108 * 'where' parameter and use the current file pointer. */
111 #define BUFFER_SIZE 8192
118 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
119 gfc_offset physical_offset
; /* Current physical file offset */
120 gfc_offset logical_offset
; /* Current logical file offset */
121 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
122 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
125 int len
; /* Physical length of the current buffer */
126 int active
; /* Length of valid bytes in the buffer */
129 int ndirty
; /* Dirty bytes starting at dirty_offset */
131 unsigned unbuffered
:1, mmaped
:1;
133 char small_buffer
[BUFFER_SIZE
];
138 /*move_pos_offset()-- Move the record pointer right or left
139 *relative to current position */
142 move_pos_offset (stream
* st
, int pos_off
)
144 unix_stream
* str
= (unix_stream
*)st
;
147 str
->active
+= pos_off
;
151 str
->logical_offset
+= pos_off
;
153 if (str
->dirty_offset
+str
->ndirty
> str
->logical_offset
)
155 if (str
->ndirty
+ pos_off
> 0)
156 str
->ndirty
+= pos_off
;
159 str
->dirty_offset
+= pos_off
+ pos_off
;
170 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
171 * standard descriptors, returning a non-standard descriptor. If the
172 * user specifies that system errors should go to standard output,
173 * then closes standard output, we don't want the system errors to a
174 * file that has been given file descriptor 1 or 0. We want to send
175 * the error to the invalid descriptor. */
180 int input
, output
, error
;
182 input
= output
= error
= 0;
184 /* Unix allocates the lowest descriptors first, so a loop is not
185 required, but this order is. */
187 if (fd
== STDIN_FILENO
)
192 if (fd
== STDOUT_FILENO
)
197 if (fd
== STDERR_FILENO
)
204 close (STDIN_FILENO
);
206 close (STDOUT_FILENO
);
208 close (STDERR_FILENO
);
214 /* write()-- Write a buffer to a descriptor, allowing for short writes */
217 writen (int fd
, char *buffer
, int len
)
225 n
= write (fd
, buffer
, len
);
238 /* readn()-- Read bytes into a buffer, allowing for short reads. If
239 * fewer than len bytes are returned, it is because we've hit the end
243 readn (int fd
, char *buffer
, int len
)
251 n
= read (fd
, buffer
, len
);
268 /* get_oserror()-- Get the most recent operating system error. For
269 * unix, this is errno. */
274 return strerror (errno
);
278 /* sys_exit()-- Terminate the program with an exit code */
287 /*********************************************************************
288 File descriptor stream functions
289 *********************************************************************/
291 /* fd_flush()-- Write bytes that need to be written */
294 fd_flush (unix_stream
* s
)
299 if (s
->physical_offset
!= s
->dirty_offset
&&
300 lseek (s
->fd
, s
->dirty_offset
, SEEK_SET
) < 0)
303 if (writen (s
->fd
, s
->buffer
+ (s
->dirty_offset
- s
->buffer_offset
),
307 s
->physical_offset
= s
->dirty_offset
+ s
->ndirty
;
309 /* don't increment file_length if the file is non-seekable */
310 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
311 s
->file_length
= s
->physical_offset
;
318 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
319 * satisfied. This subroutine gets the buffer ready for whatever is
323 fd_alloc (unix_stream
* s
, gfc_offset where
, int *len
)
328 if (*len
<= BUFFER_SIZE
)
330 new_buffer
= s
->small_buffer
;
331 read_len
= BUFFER_SIZE
;
335 new_buffer
= get_mem (*len
);
339 /* Salvage bytes currently within the buffer. This is important for
340 * devices that cannot seek. */
342 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
343 where
<= s
->buffer_offset
+ s
->active
)
346 n
= s
->active
- (where
- s
->buffer_offset
);
347 memmove (new_buffer
, s
->buffer
+ (where
- s
->buffer_offset
), n
);
352 { /* new buffer starts off empty */
356 s
->buffer_offset
= where
;
358 /* free the old buffer if necessary */
360 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
361 free_mem (s
->buffer
);
363 s
->buffer
= new_buffer
;
369 /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
370 * we've already buffered the data or we need to load it. Returns
371 * NULL on I/O error. */
374 fd_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
380 where
= s
->logical_offset
;
382 if (s
->buffer
!= NULL
&& s
->buffer_offset
<= where
&&
383 where
+ *len
<= s
->buffer_offset
+ s
->active
)
386 /* Return a position within the current buffer */
388 s
->logical_offset
= where
+ *len
;
389 return s
->buffer
+ where
- s
->buffer_offset
;
392 fd_alloc (s
, where
, len
);
394 m
= where
+ s
->active
;
396 if (s
->physical_offset
!= m
&& lseek (s
->fd
, m
, SEEK_SET
) < 0)
399 n
= read (s
->fd
, s
->buffer
+ s
->active
, s
->len
- s
->active
);
403 s
->physical_offset
= where
+ n
;
406 if (s
->active
< *len
)
407 *len
= s
->active
; /* Bytes actually available */
409 s
->logical_offset
= where
+ *len
;
415 /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
416 * we've already buffered the data or we need to load it. */
419 fd_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
424 where
= s
->logical_offset
;
426 if (s
->buffer
== NULL
|| s
->buffer_offset
> where
||
427 where
+ *len
> s
->buffer_offset
+ s
->len
)
430 if (fd_flush (s
) == FAILURE
)
432 fd_alloc (s
, where
, len
);
435 /* Return a position within the current buffer */
437 || where
> s
->dirty_offset
+ s
->ndirty
438 || s
->dirty_offset
> where
+ *len
)
439 { /* Discontiguous blocks, start with a clean buffer. */
440 /* Flush the buffer. */
443 s
->dirty_offset
= where
;
448 gfc_offset start
; /* Merge with the existing data. */
449 if (where
< s
->dirty_offset
)
452 start
= s
->dirty_offset
;
453 if (where
+ *len
> s
->dirty_offset
+ s
->ndirty
)
454 s
->ndirty
= where
+ *len
- start
;
456 s
->ndirty
= s
->dirty_offset
+ s
->ndirty
- start
;
457 s
->dirty_offset
= start
;
460 s
->logical_offset
= where
+ *len
;
462 if (where
+ *len
> s
->file_length
)
463 s
->file_length
= where
+ *len
;
465 n
= s
->logical_offset
- s
->buffer_offset
;
469 return s
->buffer
+ where
- s
->buffer_offset
;
474 fd_sfree (unix_stream
* s
)
476 if (s
->ndirty
!= 0 &&
477 (s
->buffer
!= s
->small_buffer
|| options
.all_unbuffered
||
486 fd_seek (unix_stream
* s
, gfc_offset offset
)
488 s
->physical_offset
= s
->logical_offset
= offset
;
490 return (lseek (s
->fd
, offset
, SEEK_SET
) < 0) ? FAILURE
: SUCCESS
;
494 /* truncate_file()-- Given a unit, truncate the file at the current
495 * position. Sets the physical location to the new end of the file.
496 * Returns nonzero on error. */
499 fd_truncate (unix_stream
* s
)
501 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) == -1)
504 /* non-seekable files, like terminals and fifo's fail the lseek.
505 the fd is a regular file at this point */
507 if (ftruncate (s
->fd
, s
->logical_offset
))
510 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
517 fd_close (unix_stream
* s
)
519 if (fd_flush (s
) == FAILURE
)
522 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
523 free_mem (s
->buffer
);
525 if (close (s
->fd
) < 0)
535 fd_open (unix_stream
* s
)
540 s
->st
.alloc_r_at
= (void *) fd_alloc_r_at
;
541 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
542 s
->st
.sfree
= (void *) fd_sfree
;
543 s
->st
.close
= (void *) fd_close
;
544 s
->st
.seek
= (void *) fd_seek
;
545 s
->st
.truncate
= (void *) fd_truncate
;
551 /*********************************************************************
552 mmap stream functions
554 Because mmap() is not capable of extending a file, we have to keep
555 track of how long the file is. We also have to be able to detect end
556 of file conditions. If there are multiple writers to the file (which
557 can only happen outside the current program), things will get
558 confused. Then again, things will get confused anyway.
560 *********************************************************************/
564 static int page_size
, page_mask
;
566 /* mmap_flush()-- Deletes a memory mapping if something is mapped. */
569 mmap_flush (unix_stream
* s
)
574 if (s
->buffer
== NULL
)
577 if (munmap (s
->buffer
, s
->active
))
587 /* mmap_alloc()-- mmap() a section of the file. The whole section is
588 * guaranteed to be mappable. */
591 mmap_alloc (unix_stream
* s
, gfc_offset where
, int *len
)
597 if (mmap_flush (s
) == FAILURE
)
600 offset
= where
& page_mask
; /* Round down to the next page */
602 length
= ((where
- offset
) & page_mask
) + 2 * page_size
;
604 p
= mmap (NULL
, length
, s
->prot
, MAP_SHARED
, s
->fd
, offset
);
605 if (p
== (char *) MAP_FAILED
)
610 s
->buffer_offset
= offset
;
618 mmap_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
623 where
= s
->logical_offset
;
627 if ((s
->buffer
== NULL
|| s
->buffer_offset
> where
||
628 m
> s
->buffer_offset
+ s
->active
) &&
629 mmap_alloc (s
, where
, len
) == FAILURE
)
632 if (m
> s
->file_length
)
634 *len
= s
->file_length
- s
->logical_offset
;
635 s
->logical_offset
= s
->file_length
;
638 s
->logical_offset
= m
;
640 return s
->buffer
+ (where
- s
->buffer_offset
);
645 mmap_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
648 where
= s
->logical_offset
;
650 /* If we're extending the file, we have to use file descriptor
653 if (where
+ *len
> s
->file_length
)
657 return fd_alloc_w_at (s
, len
, where
);
660 if ((s
->buffer
== NULL
|| s
->buffer_offset
> where
||
661 where
+ *len
> s
->buffer_offset
+ s
->active
||
662 where
< s
->buffer_offset
+ s
->active
) &&
663 mmap_alloc (s
, where
, len
) == FAILURE
)
666 s
->logical_offset
= where
+ *len
;
668 return s
->buffer
+ where
- s
->buffer_offset
;
673 mmap_seek (unix_stream
* s
, gfc_offset offset
)
675 s
->logical_offset
= offset
;
681 mmap_close (unix_stream
* s
)
687 if (close (s
->fd
) < 0)
696 mmap_sfree (unix_stream
* s
)
702 /* mmap_open()-- mmap_specific open. If the particular file cannot be
703 * mmap()-ed, we fall back to the file descriptor functions. */
706 mmap_open (unix_stream
* s
)
711 page_size
= getpagesize ();
714 p
= mmap (0, page_size
, s
->prot
, MAP_SHARED
, s
->fd
, 0);
715 if (p
== (char *) MAP_FAILED
)
721 munmap (p
, page_size
);
730 s
->st
.alloc_r_at
= (void *) mmap_alloc_r_at
;
731 s
->st
.alloc_w_at
= (void *) mmap_alloc_w_at
;
732 s
->st
.sfree
= (void *) mmap_sfree
;
733 s
->st
.close
= (void *) mmap_close
;
734 s
->st
.seek
= (void *) mmap_seek
;
735 s
->st
.truncate
= (void *) fd_truncate
;
737 if (lseek (s
->fd
, s
->file_length
, SEEK_SET
) < 0)
746 /*********************************************************************
747 memory stream functions - These are used for internal files
749 The idea here is that a single stream structure is created and all
750 requests must be satisfied from it. The location and size of the
751 buffer is the character variable supplied to the READ or WRITE
754 *********************************************************************/
758 mem_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
763 where
= s
->logical_offset
;
765 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
768 s
->logical_offset
= where
+ *len
;
770 n
= s
->buffer_offset
+ s
->active
- where
;
774 return s
->buffer
+ (where
- s
->buffer_offset
);
779 mem_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
784 where
= s
->logical_offset
;
788 if (where
< s
->buffer_offset
|| m
> s
->buffer_offset
+ s
->active
)
791 s
->logical_offset
= m
;
793 return s
->buffer
+ (where
- s
->buffer_offset
);
798 mem_seek (unix_stream
* s
, gfc_offset offset
)
800 if (offset
> s
->file_length
)
806 s
->logical_offset
= offset
;
812 mem_truncate (unix_stream
* s
)
819 mem_close (unix_stream
* s
)
828 mem_sfree (unix_stream
* s
)
835 /*********************************************************************
836 Public functions -- A reimplementation of this module needs to
837 define functional equivalents of the following.
838 *********************************************************************/
840 /* empty_internal_buffer()-- Zero the buffer of Internal file */
843 empty_internal_buffer(stream
*strm
)
845 unix_stream
* s
= (unix_stream
*) strm
;
846 memset(s
->buffer
, ' ', s
->file_length
);
849 /* open_internal()-- Returns a stream structure from an internal file */
852 open_internal (char *base
, int length
)
856 s
= get_mem (sizeof (unix_stream
));
859 s
->buffer_offset
= 0;
861 s
->logical_offset
= 0;
862 s
->active
= s
->file_length
= length
;
864 s
->st
.alloc_r_at
= (void *) mem_alloc_r_at
;
865 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
866 s
->st
.sfree
= (void *) mem_sfree
;
867 s
->st
.close
= (void *) mem_close
;
868 s
->st
.seek
= (void *) mem_seek
;
869 s
->st
.truncate
= (void *) mem_truncate
;
875 /* fd_to_stream()-- Given an open file descriptor, build a stream
879 fd_to_stream (int fd
, int prot
)
884 s
= get_mem (sizeof (unix_stream
));
887 s
->buffer_offset
= 0;
888 s
->physical_offset
= 0;
889 s
->logical_offset
= 0;
892 /* Get the current length of the file. */
894 fstat (fd
, &statbuf
);
895 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
907 /* Given the Fortran unit number, convert it to a C file descriptor. */
914 us
= find_unit(unit
);
918 return ((unix_stream
*) us
->s
)->fd
;
922 /* unpack_filename()-- Given a fortran string and a pointer to a
923 * buffer that is PATH_MAX characters, convert the fortran string to a
924 * C string in the buffer. Returns nonzero if this is not possible. */
927 unpack_filename (char *cstring
, const char *fstring
, int len
)
929 len
= fstrlen (fstring
, len
);
933 memmove (cstring
, fstring
, len
);
940 /* tempfile()-- Generate a temporary filename for a scratch file and
941 * open it. mkstemp() opens the file for reading and writing, but the
942 * library mode prevents anything that is not allowed. The descriptor
943 * is returned, which is -1 on error. The template is pointed to by
944 * ioparm.file, which is copied into the unit structure
945 * and freed later. */
954 tempdir
= getenv ("GFORTRAN_TMPDIR");
956 tempdir
= getenv ("TMP");
958 tempdir
= DEFAULT_TEMPDIR
;
960 template = get_mem (strlen (tempdir
) + 20);
962 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
966 fd
= mkstemp (template);
968 #else /* HAVE_MKSTEMP */
970 if (mktemp (template))
972 fd
= open (template, O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
973 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
977 #endif /* HAVE_MKSTEMP */
983 ioparm
.file
= template;
984 ioparm
.file_len
= strlen (template); /* Don't include trailing nul */
991 /* regular_file()-- Open a regular file.
992 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
993 * Returns the descriptor, which is less than zero on error. */
996 regular_file (unit_flags
*flags
)
998 char path
[PATH_MAX
+ 1];
1004 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1006 errno
= ENOENT
; /* Fake an OS error */
1012 switch (flags
->action
)
1022 case ACTION_READWRITE
:
1023 case ACTION_UNSPECIFIED
:
1028 internal_error ("regular_file(): Bad action");
1031 switch (flags
->status
)
1034 rwflag
|= O_CREAT
| O_EXCL
;
1037 case STATUS_OLD
: /* file must exist, so check for its existence */
1038 if (stat (path
, &statbuf
) < 0)
1042 case STATUS_UNKNOWN
:
1043 case STATUS_SCRATCH
:
1047 case STATUS_REPLACE
:
1048 rwflag
|= O_CREAT
| O_TRUNC
;
1052 internal_error ("regular_file(): Bad status");
1055 /* rwflag |= O_LARGEFILE; */
1057 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1058 fd
= open (path
, rwflag
, mode
);
1059 if (flags
->action
== ACTION_UNSPECIFIED
)
1063 rwflag
= rwflag
& !O_RDWR
| O_RDONLY
;
1064 fd
= open (path
, rwflag
, mode
);
1067 rwflag
= rwflag
& !O_RDONLY
| O_WRONLY
;
1068 fd
= open (path
, rwflag
, mode
);
1070 flags
->action
= ACTION_READWRITE
; /* Could not open at all. */
1072 flags
->action
= ACTION_WRITE
;
1075 flags
->action
= ACTION_READ
;
1078 flags
->action
= ACTION_READWRITE
;
1084 /* open_external()-- Open an external file, unix specific version.
1085 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1086 * Returns NULL on operating system error. */
1089 open_external (unit_flags
*flags
)
1093 if (flags
->status
== STATUS_SCRATCH
)
1096 if (flags
->action
== ACTION_UNSPECIFIED
)
1097 flags
->action
= ACTION_READWRITE
;
1098 /* We can unlink scratch files now and it will go away when closed. */
1099 unlink (ioparm
.file
);
1103 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED. */
1104 fd
= regular_file (flags
);
1111 switch (flags
->action
)
1121 case ACTION_READWRITE
:
1122 prot
= PROT_READ
| PROT_WRITE
;
1126 internal_error ("open_external(): Bad action");
1129 return fd_to_stream (fd
, prot
);
1133 /* input_stream()-- Return a stream pointer to the default input stream.
1134 * Called on initialization. */
1139 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1143 /* output_stream()-- Return a stream pointer to the default input stream.
1144 * Called on initialization. */
1147 output_stream (void)
1149 return fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1153 /* init_error_stream()-- Return a pointer to the error stream. This
1154 * subroutine is called when the stream is needed, rather than at
1155 * initialization. We want to work even if memory has been seriously
1159 init_error_stream (void)
1161 static unix_stream error
;
1163 memset (&error
, '\0', sizeof (error
));
1165 error
.fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1167 error
.st
.alloc_w_at
= (void *) fd_alloc_w_at
;
1168 error
.st
.sfree
= (void *) fd_sfree
;
1170 error
.unbuffered
= 1;
1171 error
.buffer
= error
.small_buffer
;
1173 return (stream
*) & error
;
1177 /* compare_file_filename()-- Given an open stream and a fortran string
1178 * that is a filename, figure out if the file is the same as the
1182 compare_file_filename (stream
* s
, const char *name
, int len
)
1184 char path
[PATH_MAX
+ 1];
1185 struct stat st1
, st2
;
1187 if (unpack_filename (path
, name
, len
))
1188 return 0; /* Can't be the same */
1190 /* If the filename doesn't exist, then there is no match with the
1193 if (stat (path
, &st1
) < 0)
1196 fstat (((unix_stream
*) s
)->fd
, &st2
);
1198 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1202 /* find_file0()-- Recursive work function for find_file() */
1205 find_file0 (gfc_unit
* u
, struct stat
*st1
)
1213 if (fstat (((unix_stream
*) u
->s
)->fd
, &st2
) >= 0 &&
1214 st1
->st_dev
== st2
.st_dev
&& st1
->st_ino
== st2
.st_ino
)
1217 v
= find_file0 (u
->left
, st1
);
1221 v
= find_file0 (u
->right
, st1
);
1229 /* find_file()-- Take the current filename and see if there is a unit
1230 * that has the file already open. Returns a pointer to the unit if so. */
1235 char path
[PATH_MAX
+ 1];
1236 struct stat statbuf
;
1238 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1241 if (stat (path
, &statbuf
) < 0)
1244 return find_file0 (g
.unit_root
, &statbuf
);
1248 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1252 stream_at_bof (stream
* s
)
1256 us
= (unix_stream
*) s
;
1259 return 0; /* File is not seekable */
1261 return us
->logical_offset
== 0;
1265 /* stream_at_eof()-- Returns nonzero if the stream is at the beginning
1269 stream_at_eof (stream
* s
)
1273 us
= (unix_stream
*) s
;
1276 return 0; /* File is not seekable */
1278 return us
->logical_offset
== us
->dirty_offset
;
1282 /* delete_file()-- Given a unit structure, delete the file associated
1283 * with the unit. Returns nonzero if something went wrong. */
1286 delete_file (gfc_unit
* u
)
1288 char path
[PATH_MAX
+ 1];
1290 if (unpack_filename (path
, u
->file
, u
->file_len
))
1291 { /* Shouldn't be possible */
1296 return unlink (path
);
1300 /* file_exists()-- Returns nonzero if the current filename exists on
1306 char path
[PATH_MAX
+ 1];
1307 struct stat statbuf
;
1309 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1312 if (stat (path
, &statbuf
) < 0)
1320 static const char *yes
= "YES", *no
= "NO", *unknown
= "UNKNOWN";
1322 /* inquire_sequential()-- Given a fortran string, determine if the
1323 * file is suitable for sequential access. Returns a C-style
1327 inquire_sequential (const char *string
, int len
)
1329 char path
[PATH_MAX
+ 1];
1330 struct stat statbuf
;
1332 if (string
== NULL
||
1333 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1336 if (S_ISREG (statbuf
.st_mode
) ||
1337 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1340 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1347 /* inquire_direct()-- Given a fortran string, determine if the file is
1348 * suitable for direct access. Returns a C-style string. */
1351 inquire_direct (const char *string
, int len
)
1353 char path
[PATH_MAX
+ 1];
1354 struct stat statbuf
;
1356 if (string
== NULL
||
1357 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1360 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1363 if (S_ISDIR (statbuf
.st_mode
) ||
1364 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1371 /* inquire_formatted()-- Given a fortran string, determine if the file
1372 * is suitable for formatted form. Returns a C-style string. */
1375 inquire_formatted (const char *string
, int len
)
1377 char path
[PATH_MAX
+ 1];
1378 struct stat statbuf
;
1380 if (string
== NULL
||
1381 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1384 if (S_ISREG (statbuf
.st_mode
) ||
1385 S_ISBLK (statbuf
.st_mode
) ||
1386 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1389 if (S_ISDIR (statbuf
.st_mode
))
1396 /* inquire_unformatted()-- Given a fortran string, determine if the file
1397 * is suitable for unformatted form. Returns a C-style string. */
1400 inquire_unformatted (const char *string
, int len
)
1402 return inquire_formatted (string
, len
);
1406 /* inquire_access()-- Given a fortran string, determine if the file is
1407 * suitable for access. */
1410 inquire_access (const char *string
, int len
, int mode
)
1412 char path
[PATH_MAX
+ 1];
1414 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1415 access (path
, mode
) < 0)
1422 /* inquire_read()-- Given a fortran string, determine if the file is
1423 * suitable for READ access. */
1426 inquire_read (const char *string
, int len
)
1428 return inquire_access (string
, len
, R_OK
);
1432 /* inquire_write()-- Given a fortran string, determine if the file is
1433 * suitable for READ access. */
1436 inquire_write (const char *string
, int len
)
1438 return inquire_access (string
, len
, W_OK
);
1442 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1443 * suitable for read and write access. */
1446 inquire_readwrite (const char *string
, int len
)
1448 return inquire_access (string
, len
, R_OK
| W_OK
);
1452 /* file_length()-- Return the file length in bytes, -1 if unknown */
1455 file_length (stream
* s
)
1457 return ((unix_stream
*) s
)->file_length
;
1461 /* file_position()-- Return the current position of the file */
1464 file_position (stream
* s
)
1466 return ((unix_stream
*) s
)->logical_offset
;
1470 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1474 is_seekable (stream
* s
)
1476 /* by convention, if file_length == -1, the file is not seekable
1477 note that a mmapped file is always seekable, an fd_ file may
1479 return ((unix_stream
*) s
)->file_length
!=-1;
1485 return fd_flush( (unix_stream
*) s
);
1489 /* How files are stored: This is an operating-system specific issue,
1490 and therefore belongs here. There are three cases to consider.
1493 Records are written as block of bytes corresponding to the record
1494 length of the file. This goes for both formatted and unformatted
1495 records. Positioning is done explicitly for each data transfer,
1496 so positioning is not much of an issue.
1498 Sequential Formatted:
1499 Records are separated by newline characters. The newline character
1500 is prohibited from appearing in a string. If it does, this will be
1501 messed up on the next read. End of file is also the end of a record.
1503 Sequential Unformatted:
1504 In this case, we are merely copying bytes to and from main storage,
1505 yet we need to keep track of varying record lengths. We adopt
1506 the solution used by f2c. Each record contains a pair of length
1509 Length of record n in bytes
1511 Length of record n in bytes
1513 Length of record n+1 in bytes
1515 Length of record n+1 in bytes
1517 The length is stored at the end of a record to allow backspacing to the
1518 previous record. Between data transfer statements, the file pointer
1519 is left pointing to the first length of the current record.
1521 ENDFILE records are never explicitly stored.