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, 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA. */
31 /* Unix stream I/O module */
42 #ifdef HAVE_SYS_MMAN_H
48 #include "libgfortran.h"
56 #define MAP_FAILED ((void *) -1)
67 /* These flags aren't defined on all targets (mingw32), so provide them
85 /* This implementation of stream I/O is based on the paper:
87 * "Exploiting the advantages of mapped files for stream I/O",
88 * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
89 * USENIX conference", p. 27-42.
91 * It differs in a number of ways from the version described in the
92 * paper. First of all, threads are not an issue during I/O and we
93 * also don't have to worry about having multiple regions, since
94 * fortran's I/O model only allows you to be one place at a time.
96 * On the other hand, we have to be able to writing at the end of a
97 * stream, read from the start of a stream or read and write blocks of
98 * bytes from an arbitrary position. After opening a file, a pointer
99 * to a stream structure is returned, which is used to handle file
100 * accesses until the file is closed.
102 * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
103 * pointer to a block of memory that mirror the file at position
104 * 'where' that is 'len' bytes long. The len integer is updated to
105 * reflect how many bytes were actually read. The only reason for a
106 * short read is end of file. The file pointer is updated. The
107 * pointer is valid until the next call to salloc_*.
109 * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
110 * a pointer to a block of memory that is updated to reflect the state
111 * of the file. The length of the buffer is always equal to that
112 * requested. The buffer must be completely set by the caller. When
113 * data has been written, the sfree() function must be called to
114 * indicate that the caller is done writing data to the buffer. This
115 * may or may not cause a physical write.
117 * Short forms of these are salloc_r() and salloc_w() which drop the
118 * 'where' parameter and use the current file pointer. */
121 #define BUFFER_SIZE 8192
128 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
129 gfc_offset physical_offset
; /* Current physical file offset */
130 gfc_offset logical_offset
; /* Current logical file offset */
131 gfc_offset dirty_offset
; /* Start of modified bytes in buffer */
132 gfc_offset file_length
; /* Length of the file, -1 if not seekable. */
135 int len
; /* Physical length of the current buffer */
136 int active
; /* Length of valid bytes in the buffer */
139 int ndirty
; /* Dirty bytes starting at dirty_offset */
141 int special_file
; /* =1 if the fd refers to a special file */
143 unsigned unbuffered
:1, mmaped
:1;
145 char small_buffer
[BUFFER_SIZE
];
150 /*move_pos_offset()-- Move the record pointer right or left
151 *relative to current position */
154 move_pos_offset (stream
* st
, int pos_off
)
156 unix_stream
* str
= (unix_stream
*)st
;
159 str
->logical_offset
+= pos_off
;
161 if (str
->dirty_offset
+ str
->ndirty
> str
->logical_offset
)
163 if (str
->ndirty
+ pos_off
> 0)
164 str
->ndirty
+= pos_off
;
167 str
->dirty_offset
+= pos_off
+ pos_off
;
178 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
179 * standard descriptors, returning a non-standard descriptor. If the
180 * user specifies that system errors should go to standard output,
181 * then closes standard output, we don't want the system errors to a
182 * file that has been given file descriptor 1 or 0. We want to send
183 * the error to the invalid descriptor. */
188 int input
, output
, error
;
190 input
= output
= error
= 0;
192 /* Unix allocates the lowest descriptors first, so a loop is not
193 required, but this order is. */
195 if (fd
== STDIN_FILENO
)
200 if (fd
== STDOUT_FILENO
)
205 if (fd
== STDERR_FILENO
)
212 close (STDIN_FILENO
);
214 close (STDOUT_FILENO
);
216 close (STDERR_FILENO
);
222 /* write()-- Write a buffer to a descriptor, allowing for short writes */
225 writen (int fd
, char *buffer
, int len
)
233 n
= write (fd
, buffer
, len
);
246 /* readn()-- Read bytes into a buffer, allowing for short reads. If
247 * fewer than len bytes are returned, it is because we've hit the end
251 readn (int fd
, char *buffer
, int len
)
259 n
= read (fd
, buffer
, len
);
276 /* get_oserror()-- Get the most recent operating system error. For
277 * unix, this is errno. */
282 return strerror (errno
);
286 /* sys_exit()-- Terminate the program with an exit code */
295 /*********************************************************************
296 File descriptor stream functions
297 *********************************************************************/
299 /* fd_flush()-- Write bytes that need to be written */
302 fd_flush (unix_stream
* s
)
307 if (s
->physical_offset
!= s
->dirty_offset
&&
308 lseek (s
->fd
, s
->dirty_offset
, SEEK_SET
) < 0)
311 if (writen (s
->fd
, s
->buffer
+ (s
->dirty_offset
- s
->buffer_offset
),
315 s
->physical_offset
= s
->dirty_offset
+ s
->ndirty
;
317 /* don't increment file_length if the file is non-seekable */
318 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
319 s
->file_length
= s
->physical_offset
;
326 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
327 * satisfied. This subroutine gets the buffer ready for whatever is
331 fd_alloc (unix_stream
* s
, gfc_offset where
,
332 int *len
__attribute__ ((unused
)))
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 Using ftruncate on a seekable special file (like /dev/null)
515 is undefined, so we treat it as if the ftruncate failed.
517 #ifdef HAVE_FTRUNCATE
518 if (s
->special_file
|| ftruncate (s
->fd
, s
->logical_offset
))
521 if (s
->special_file
|| chsize (s
->fd
, s
->logical_offset
))
525 s
->physical_offset
= s
->file_length
= 0;
529 s
->physical_offset
= s
->file_length
= s
->logical_offset
;
536 fd_close (unix_stream
* s
)
538 if (fd_flush (s
) == FAILURE
)
541 if (s
->buffer
!= NULL
&& s
->buffer
!= s
->small_buffer
)
542 free_mem (s
->buffer
);
544 if (s
->fd
!= STDOUT_FILENO
&& s
->fd
!= STDERR_FILENO
)
546 if (close (s
->fd
) < 0)
557 fd_open (unix_stream
* s
)
562 s
->st
.alloc_r_at
= (void *) fd_alloc_r_at
;
563 s
->st
.alloc_w_at
= (void *) fd_alloc_w_at
;
564 s
->st
.sfree
= (void *) fd_sfree
;
565 s
->st
.close
= (void *) fd_close
;
566 s
->st
.seek
= (void *) fd_seek
;
567 s
->st
.truncate
= (void *) fd_truncate
;
573 /*********************************************************************
574 mmap stream functions
576 Because mmap() is not capable of extending a file, we have to keep
577 track of how long the file is. We also have to be able to detect end
578 of file conditions. If there are multiple writers to the file (which
579 can only happen outside the current program), things will get
580 confused. Then again, things will get confused anyway.
582 *********************************************************************/
586 static int page_size
, page_mask
;
588 /* mmap_flush()-- Deletes a memory mapping if something is mapped. */
591 mmap_flush (unix_stream
* s
)
596 if (s
->buffer
== NULL
)
599 if (munmap (s
->buffer
, s
->active
))
609 /* mmap_alloc()-- mmap() a section of the file. The whole section is
610 * guaranteed to be mappable. */
613 mmap_alloc (unix_stream
* s
, gfc_offset where
,
614 int *len
__attribute__ ((unused
)))
620 if (mmap_flush (s
) == FAILURE
)
623 offset
= where
& page_mask
; /* Round down to the next page */
625 length
= ((where
- offset
) & page_mask
) + 2 * page_size
;
627 p
= mmap (NULL
, length
, s
->prot
, MAP_SHARED
, s
->fd
, offset
);
628 if (p
== (char *) MAP_FAILED
)
633 s
->buffer_offset
= offset
;
641 mmap_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
646 where
= s
->logical_offset
;
650 if ((s
->buffer
== NULL
|| s
->buffer_offset
> where
||
651 m
> s
->buffer_offset
+ s
->active
) &&
652 mmap_alloc (s
, where
, len
) == FAILURE
)
655 if (m
> s
->file_length
)
657 *len
= s
->file_length
- s
->logical_offset
;
658 s
->logical_offset
= s
->file_length
;
661 s
->logical_offset
= m
;
663 return s
->buffer
+ (where
- s
->buffer_offset
);
668 mmap_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
671 where
= s
->logical_offset
;
673 /* If we're extending the file, we have to use file descriptor
676 if (where
+ *len
> s
->file_length
)
680 return fd_alloc_w_at (s
, len
, where
);
683 if ((s
->buffer
== NULL
|| s
->buffer_offset
> where
||
684 where
+ *len
> s
->buffer_offset
+ s
->active
||
685 where
< s
->buffer_offset
+ s
->active
) &&
686 mmap_alloc (s
, where
, len
) == FAILURE
)
689 s
->logical_offset
= where
+ *len
;
691 return s
->buffer
+ where
- s
->buffer_offset
;
696 mmap_seek (unix_stream
* s
, gfc_offset offset
)
698 s
->logical_offset
= offset
;
704 mmap_close (unix_stream
* s
)
710 if (close (s
->fd
) < 0)
719 mmap_sfree (unix_stream
* s
__attribute__ ((unused
)))
725 /* mmap_open()-- mmap_specific open. If the particular file cannot be
726 * mmap()-ed, we fall back to the file descriptor functions. */
729 mmap_open (unix_stream
* s
__attribute__ ((unused
)))
734 page_size
= getpagesize ();
737 p
= mmap (0, page_size
, s
->prot
, MAP_SHARED
, s
->fd
, 0);
738 if (p
== (char *) MAP_FAILED
)
744 munmap (p
, page_size
);
753 s
->st
.alloc_r_at
= (void *) mmap_alloc_r_at
;
754 s
->st
.alloc_w_at
= (void *) mmap_alloc_w_at
;
755 s
->st
.sfree
= (void *) mmap_sfree
;
756 s
->st
.close
= (void *) mmap_close
;
757 s
->st
.seek
= (void *) mmap_seek
;
758 s
->st
.truncate
= (void *) fd_truncate
;
760 if (lseek (s
->fd
, s
->file_length
, SEEK_SET
) < 0)
769 /*********************************************************************
770 memory stream functions - These are used for internal files
772 The idea here is that a single stream structure is created and all
773 requests must be satisfied from it. The location and size of the
774 buffer is the character variable supplied to the READ or WRITE
777 *********************************************************************/
781 mem_alloc_r_at (unix_stream
* s
, int *len
, gfc_offset where
)
786 where
= s
->logical_offset
;
788 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
791 s
->logical_offset
= where
+ *len
;
793 n
= s
->buffer_offset
+ s
->active
- where
;
797 return s
->buffer
+ (where
- s
->buffer_offset
);
802 mem_alloc_w_at (unix_stream
* s
, int *len
, gfc_offset where
)
807 where
= s
->logical_offset
;
811 if (where
< s
->buffer_offset
|| m
> s
->buffer_offset
+ s
->active
)
814 s
->logical_offset
= m
;
816 return s
->buffer
+ (where
- s
->buffer_offset
);
821 mem_seek (unix_stream
* s
, gfc_offset offset
)
823 if (offset
> s
->file_length
)
829 s
->logical_offset
= offset
;
835 mem_truncate (unix_stream
* s
__attribute__ ((unused
)))
842 mem_close (unix_stream
* s
)
851 mem_sfree (unix_stream
* s
__attribute__ ((unused
)))
858 /*********************************************************************
859 Public functions -- A reimplementation of this module needs to
860 define functional equivalents of the following.
861 *********************************************************************/
863 /* empty_internal_buffer()-- Zero the buffer of Internal file */
866 empty_internal_buffer(stream
*strm
)
868 unix_stream
* s
= (unix_stream
*) strm
;
869 memset(s
->buffer
, ' ', s
->file_length
);
872 /* open_internal()-- Returns a stream structure from an internal file */
875 open_internal (char *base
, int length
)
879 s
= get_mem (sizeof (unix_stream
));
880 memset (s
, '\0', sizeof (unix_stream
));
883 s
->buffer_offset
= 0;
885 s
->logical_offset
= 0;
886 s
->active
= s
->file_length
= length
;
888 s
->st
.alloc_r_at
= (void *) mem_alloc_r_at
;
889 s
->st
.alloc_w_at
= (void *) mem_alloc_w_at
;
890 s
->st
.sfree
= (void *) mem_sfree
;
891 s
->st
.close
= (void *) mem_close
;
892 s
->st
.seek
= (void *) mem_seek
;
893 s
->st
.truncate
= (void *) mem_truncate
;
899 /* fd_to_stream()-- Given an open file descriptor, build a stream
903 fd_to_stream (int fd
, int prot
, int avoid_mmap
)
908 s
= get_mem (sizeof (unix_stream
));
909 memset (s
, '\0', sizeof (unix_stream
));
912 s
->buffer_offset
= 0;
913 s
->physical_offset
= 0;
914 s
->logical_offset
= 0;
917 /* Get the current length of the file. */
919 fstat (fd
, &statbuf
);
920 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
921 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
936 /* Given the Fortran unit number, convert it to a C file descriptor. */
943 us
= find_unit(unit
);
947 return ((unix_stream
*) us
->s
)->fd
;
951 /* unpack_filename()-- Given a fortran string and a pointer to a
952 * buffer that is PATH_MAX characters, convert the fortran string to a
953 * C string in the buffer. Returns nonzero if this is not possible. */
956 unpack_filename (char *cstring
, const char *fstring
, int len
)
958 len
= fstrlen (fstring
, len
);
962 memmove (cstring
, fstring
, len
);
969 /* tempfile()-- Generate a temporary filename for a scratch file and
970 * open it. mkstemp() opens the file for reading and writing, but the
971 * library mode prevents anything that is not allowed. The descriptor
972 * is returned, which is -1 on error. The template is pointed to by
973 * ioparm.file, which is copied into the unit structure
974 * and freed later. */
983 tempdir
= getenv ("GFORTRAN_TMPDIR");
985 tempdir
= getenv ("TMP");
987 tempdir
= DEFAULT_TEMPDIR
;
989 template = get_mem (strlen (tempdir
) + 20);
991 st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir
);
995 fd
= mkstemp (template);
997 #else /* HAVE_MKSTEMP */
999 if (mktemp (template))
1001 fd
= open (template, O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1002 while (!(fd
== -1 && errno
== EEXIST
) && mktemp (template));
1006 #endif /* HAVE_MKSTEMP */
1009 free_mem (template);
1012 ioparm
.file
= template;
1013 ioparm
.file_len
= strlen (template); /* Don't include trailing nul */
1020 /* regular_file()-- Open a regular file.
1021 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1022 * unless an error occurs.
1023 * Returns the descriptor, which is less than zero on error. */
1026 regular_file (unit_flags
*flags
)
1028 char path
[PATH_MAX
+ 1];
1034 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1036 errno
= ENOENT
; /* Fake an OS error */
1042 switch (flags
->action
)
1052 case ACTION_READWRITE
:
1053 case ACTION_UNSPECIFIED
:
1058 internal_error ("regular_file(): Bad action");
1061 switch (flags
->status
)
1064 crflag
= O_CREAT
| O_EXCL
;
1067 case STATUS_OLD
: /* open will fail if the file does not exist*/
1071 case STATUS_UNKNOWN
:
1072 case STATUS_SCRATCH
:
1076 case STATUS_REPLACE
:
1077 crflag
= O_CREAT
| O_TRUNC
;
1081 internal_error ("regular_file(): Bad status");
1084 /* rwflag |= O_LARGEFILE; */
1086 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1087 fd
= open (path
, rwflag
| crflag
, mode
);
1088 if (flags
->action
!= ACTION_UNSPECIFIED
)
1093 flags
->action
= ACTION_READWRITE
;
1096 if (errno
!= EACCES
)
1099 /* retry for read-only access */
1101 fd
= open (path
, rwflag
| crflag
, mode
);
1104 flags
->action
= ACTION_READ
;
1105 return fd
; /* success */
1108 if (errno
!= EACCES
)
1109 return fd
; /* failure */
1111 /* retry for write-only access */
1113 fd
= open (path
, rwflag
| crflag
, mode
);
1116 flags
->action
= ACTION_WRITE
;
1117 return fd
; /* success */
1119 return fd
; /* failure */
1123 /* open_external()-- Open an external file, unix specific version.
1124 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1125 * Returns NULL on operating system error. */
1128 open_external (unit_flags
*flags
)
1132 if (flags
->status
== STATUS_SCRATCH
)
1135 if (flags
->action
== ACTION_UNSPECIFIED
)
1136 flags
->action
= ACTION_READWRITE
;
1137 /* We can unlink scratch files now and it will go away when closed. */
1138 unlink (ioparm
.file
);
1142 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1144 fd
= regular_file (flags
);
1151 switch (flags
->action
)
1161 case ACTION_READWRITE
:
1162 prot
= PROT_READ
| PROT_WRITE
;
1166 internal_error ("open_external(): Bad action");
1169 return fd_to_stream (fd
, prot
, 0);
1173 /* input_stream()-- Return a stream pointer to the default input stream.
1174 * Called on initialization. */
1179 return fd_to_stream (STDIN_FILENO
, PROT_READ
, 1);
1183 /* output_stream()-- Return a stream pointer to the default output stream.
1184 * Called on initialization. */
1187 output_stream (void)
1189 return fd_to_stream (STDOUT_FILENO
, PROT_WRITE
, 1);
1193 /* error_stream()-- Return a stream pointer to the default error stream.
1194 * Called on initialization. */
1199 return fd_to_stream (STDERR_FILENO
, PROT_WRITE
, 1);
1202 /* init_error_stream()-- Return a pointer to the error stream. This
1203 * subroutine is called when the stream is needed, rather than at
1204 * initialization. We want to work even if memory has been seriously
1208 init_error_stream (void)
1210 static unix_stream error
;
1212 memset (&error
, '\0', sizeof (error
));
1214 error
.fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1216 error
.st
.alloc_w_at
= (void *) fd_alloc_w_at
;
1217 error
.st
.sfree
= (void *) fd_sfree
;
1219 error
.unbuffered
= 1;
1220 error
.buffer
= error
.small_buffer
;
1222 return (stream
*) & error
;
1226 /* compare_file_filename()-- Given an open stream and a fortran string
1227 * that is a filename, figure out if the file is the same as the
1231 compare_file_filename (stream
* s
, const char *name
, int len
)
1233 char path
[PATH_MAX
+ 1];
1234 struct stat st1
, st2
;
1236 if (unpack_filename (path
, name
, len
))
1237 return 0; /* Can't be the same */
1239 /* If the filename doesn't exist, then there is no match with the
1242 if (stat (path
, &st1
) < 0)
1245 fstat (((unix_stream
*) s
)->fd
, &st2
);
1247 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1251 /* find_file0()-- Recursive work function for find_file() */
1254 find_file0 (gfc_unit
* u
, struct stat
*st1
)
1262 if (fstat (((unix_stream
*) u
->s
)->fd
, &st2
) >= 0 &&
1263 st1
->st_dev
== st2
.st_dev
&& st1
->st_ino
== st2
.st_ino
)
1266 v
= find_file0 (u
->left
, st1
);
1270 v
= find_file0 (u
->right
, st1
);
1278 /* find_file()-- Take the current filename and see if there is a unit
1279 * that has the file already open. Returns a pointer to the unit if so. */
1284 char path
[PATH_MAX
+ 1];
1285 struct stat statbuf
;
1287 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1290 if (stat (path
, &statbuf
) < 0)
1293 return find_file0 (g
.unit_root
, &statbuf
);
1297 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1301 stream_at_bof (stream
* s
)
1305 if (!is_seekable (s
))
1308 us
= (unix_stream
*) s
;
1310 return us
->logical_offset
== 0;
1314 /* stream_at_eof()-- Returns nonzero if the stream is at the beginning
1318 stream_at_eof (stream
* s
)
1322 if (!is_seekable (s
))
1325 us
= (unix_stream
*) s
;
1327 return us
->logical_offset
== us
->dirty_offset
;
1331 /* delete_file()-- Given a unit structure, delete the file associated
1332 * with the unit. Returns nonzero if something went wrong. */
1335 delete_file (gfc_unit
* u
)
1337 char path
[PATH_MAX
+ 1];
1339 if (unpack_filename (path
, u
->file
, u
->file_len
))
1340 { /* Shouldn't be possible */
1345 return unlink (path
);
1349 /* file_exists()-- Returns nonzero if the current filename exists on
1355 char path
[PATH_MAX
+ 1];
1356 struct stat statbuf
;
1358 if (unpack_filename (path
, ioparm
.file
, ioparm
.file_len
))
1361 if (stat (path
, &statbuf
) < 0)
1369 static const char *yes
= "YES", *no
= "NO", *unknown
= "UNKNOWN";
1371 /* inquire_sequential()-- Given a fortran string, determine if the
1372 * file is suitable for sequential access. Returns a C-style
1376 inquire_sequential (const char *string
, int len
)
1378 char path
[PATH_MAX
+ 1];
1379 struct stat statbuf
;
1381 if (string
== NULL
||
1382 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1385 if (S_ISREG (statbuf
.st_mode
) ||
1386 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1389 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1396 /* inquire_direct()-- Given a fortran string, determine if the file is
1397 * suitable for direct access. Returns a C-style string. */
1400 inquire_direct (const char *string
, int len
)
1402 char path
[PATH_MAX
+ 1];
1403 struct stat statbuf
;
1405 if (string
== NULL
||
1406 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1409 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1412 if (S_ISDIR (statbuf
.st_mode
) ||
1413 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1420 /* inquire_formatted()-- Given a fortran string, determine if the file
1421 * is suitable for formatted form. Returns a C-style string. */
1424 inquire_formatted (const char *string
, int len
)
1426 char path
[PATH_MAX
+ 1];
1427 struct stat statbuf
;
1429 if (string
== NULL
||
1430 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1433 if (S_ISREG (statbuf
.st_mode
) ||
1434 S_ISBLK (statbuf
.st_mode
) ||
1435 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1438 if (S_ISDIR (statbuf
.st_mode
))
1445 /* inquire_unformatted()-- Given a fortran string, determine if the file
1446 * is suitable for unformatted form. Returns a C-style string. */
1449 inquire_unformatted (const char *string
, int len
)
1451 return inquire_formatted (string
, len
);
1455 /* inquire_access()-- Given a fortran string, determine if the file is
1456 * suitable for access. */
1459 inquire_access (const char *string
, int len
, int mode
)
1461 char path
[PATH_MAX
+ 1];
1463 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1464 access (path
, mode
) < 0)
1471 /* inquire_read()-- Given a fortran string, determine if the file is
1472 * suitable for READ access. */
1475 inquire_read (const char *string
, int len
)
1477 return inquire_access (string
, len
, R_OK
);
1481 /* inquire_write()-- Given a fortran string, determine if the file is
1482 * suitable for READ access. */
1485 inquire_write (const char *string
, int len
)
1487 return inquire_access (string
, len
, W_OK
);
1491 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1492 * suitable for read and write access. */
1495 inquire_readwrite (const char *string
, int len
)
1497 return inquire_access (string
, len
, R_OK
| W_OK
);
1501 /* file_length()-- Return the file length in bytes, -1 if unknown */
1504 file_length (stream
* s
)
1506 return ((unix_stream
*) s
)->file_length
;
1510 /* file_position()-- Return the current position of the file */
1513 file_position (stream
* s
)
1515 return ((unix_stream
*) s
)->logical_offset
;
1519 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1523 is_seekable (stream
* s
)
1525 /* by convention, if file_length == -1, the file is not seekable
1526 note that a mmapped file is always seekable, an fd_ file may
1528 return ((unix_stream
*) s
)->file_length
!=-1;
1534 return fd_flush( (unix_stream
*) s
);
1538 /* How files are stored: This is an operating-system specific issue,
1539 and therefore belongs here. There are three cases to consider.
1542 Records are written as block of bytes corresponding to the record
1543 length of the file. This goes for both formatted and unformatted
1544 records. Positioning is done explicitly for each data transfer,
1545 so positioning is not much of an issue.
1547 Sequential Formatted:
1548 Records are separated by newline characters. The newline character
1549 is prohibited from appearing in a string. If it does, this will be
1550 messed up on the next read. End of file is also the end of a record.
1552 Sequential Unformatted:
1553 In this case, we are merely copying bytes to and from main storage,
1554 yet we need to keep track of varying record lengths. We adopt
1555 the solution used by f2c. Each record contains a pair of length
1558 Length of record n in bytes
1560 Length of record n in bytes
1562 Length of record n+1 in bytes
1564 Length of record n+1 in bytes
1566 The length is stored at the end of a record to allow backspacing to the
1567 previous record. Between data transfer statements, the file pointer
1568 is left pointing to the first length of the current record.
1570 ENDFILE records are never explicitly stored.