1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 /* Unix stream I/O module */
43 /* For mingw, we don't identify files by their inode number, but by a
44 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
47 #define WIN32_LEAN_AND_MEAN
50 #define lseek _lseeki64
51 #define fstat _fstati64
53 typedef struct _stati64 gfstat_t
;
55 #ifndef HAVE_WORKING_STAT
57 id_from_handle (HANDLE hFile
)
59 BY_HANDLE_FILE_INFORMATION FileInformation
;
61 if (hFile
== INVALID_HANDLE_VALUE
)
64 memset (&FileInformation
, 0, sizeof(FileInformation
));
65 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
68 return ((uint64_t) FileInformation
.nFileIndexLow
)
69 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
74 id_from_path (const char *path
)
79 if (!path
|| !*path
|| access (path
, F_OK
))
82 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
83 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
85 res
= id_from_handle (hFile
);
92 id_from_fd (const int fd
)
94 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
100 typedef struct stat gfstat_t
;
104 #define PATH_MAX 1024
115 /* These flags aren't defined on all targets (mingw32), so provide them
148 /* Fallback implementation of access() on systems that don't have it.
149 Only modes R_OK, W_OK and F_OK are used in this file. */
152 fallback_access (const char *path
, int mode
)
154 if ((mode
& R_OK
) && open (path
, O_RDONLY
) < 0)
157 if ((mode
& W_OK
) && open (path
, O_WRONLY
) < 0)
163 return stat (path
, &st
);
170 #define access fallback_access
174 /* Unix and internal stream I/O module */
176 static const int BUFFER_SIZE
= 8192;
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. */
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. */
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
);
223 /* If the stream corresponds to a preconnected unit, we flush the
224 corresponding C stream. This is bugware for mixed C-Fortran codes
225 where the C code doesn't flush I/O before returning. */
227 flush_if_preconnected (stream
* s
)
231 fd
= ((unix_stream
*) s
)->fd
;
232 if (fd
== STDIN_FILENO
)
234 else if (fd
== STDOUT_FILENO
)
236 else if (fd
== STDERR_FILENO
)
241 /* get_oserror()-- Get the most recent operating system error. For
242 * unix, this is errno. */
247 return strerror (errno
);
251 /********************************************************************
252 Raw I/O functions (read, write, seek, tell, truncate, close).
254 These functions wrap the basic POSIX I/O syscalls. Any deviation in
255 semantics is a bug, except the following: write restarts in case
256 of being interrupted by a signal, and as the first argument the
257 functions take the unix_stream struct rather than an integer file
258 descriptor. Also, for POSIX read() and write() a nbyte argument larger
259 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
260 than size_t as for POSIX read/write.
261 *********************************************************************/
264 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
270 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
272 /* For read we can't do I/O in a loop like raw_write does, because
273 that will break applications that wait for interactive I/O. */
274 return read (s
->fd
, buf
, nbyte
);
278 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
280 ssize_t trans
, bytes_left
;
284 buf_st
= (char *) buf
;
286 /* We must write in a loop since some systems don't restart system
287 calls in case of a signal. */
288 while (bytes_left
> 0)
290 trans
= write (s
->fd
, buf_st
, bytes_left
);
302 return nbyte
- bytes_left
;
306 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
308 return lseek (s
->fd
, offset
, whence
);
312 raw_tell (unix_stream
* s
)
314 return lseek (s
->fd
, 0, SEEK_CUR
);
318 raw_truncate (unix_stream
* s
, gfc_offset length
)
329 h
= (HANDLE
) _get_osfhandle (s
->fd
);
330 if (h
== INVALID_HANDLE_VALUE
)
335 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
338 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
340 if (!SetEndOfFile (h
))
345 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
349 lseek (s
->fd
, cur
, SEEK_SET
);
351 #elif defined HAVE_FTRUNCATE
352 return ftruncate (s
->fd
, length
);
353 #elif defined HAVE_CHSIZE
354 return chsize (s
->fd
, length
);
356 runtime_error ("required ftruncate or chsize support not present");
362 raw_close (unix_stream
* s
)
366 if (s
->fd
!= STDOUT_FILENO
367 && s
->fd
!= STDERR_FILENO
368 && s
->fd
!= STDIN_FILENO
)
369 retval
= close (s
->fd
);
377 raw_init (unix_stream
* s
)
379 s
->st
.read
= (void *) raw_read
;
380 s
->st
.write
= (void *) raw_write
;
381 s
->st
.seek
= (void *) raw_seek
;
382 s
->st
.tell
= (void *) raw_tell
;
383 s
->st
.trunc
= (void *) raw_truncate
;
384 s
->st
.close
= (void *) raw_close
;
385 s
->st
.flush
= (void *) raw_flush
;
392 /*********************************************************************
393 Buffered I/O functions. These functions have the same semantics as the
394 raw I/O functions above, except that they are buffered in order to
395 improve performance. The buffer must be flushed when switching from
396 reading to writing and vice versa.
397 *********************************************************************/
400 buf_flush (unix_stream
* s
)
404 /* Flushing in read mode means discarding read bytes. */
410 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->buffer_offset
411 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
414 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
416 s
->physical_offset
= s
->buffer_offset
+ writelen
;
418 /* Don't increment file_length if the file is non-seekable. */
419 if (s
->file_length
!= -1 && s
->physical_offset
> s
->file_length
)
420 s
->file_length
= s
->physical_offset
;
422 s
->ndirty
-= writelen
;
434 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
437 s
->buffer_offset
= s
->logical_offset
;
439 /* Is the data we want in the buffer? */
440 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
441 && s
->buffer_offset
<= s
->logical_offset
)
442 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
445 /* First copy the active bytes if applicable, then read the rest
446 either directly or filling the buffer. */
449 ssize_t to_read
, did_read
;
450 gfc_offset new_logical
;
453 if (s
->logical_offset
>= s
->buffer_offset
454 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
456 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
457 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
461 /* At this point we consider all bytes in the buffer discarded. */
462 to_read
= nbyte
- nread
;
463 new_logical
= s
->logical_offset
+ nread
;
464 if (s
->file_length
!= -1 && s
->physical_offset
!= new_logical
465 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
467 s
->buffer_offset
= s
->physical_offset
= new_logical
;
468 if (to_read
<= BUFFER_SIZE
/2)
470 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
471 s
->physical_offset
+= did_read
;
472 s
->active
= did_read
;
473 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
474 memcpy (p
, s
->buffer
, did_read
);
478 did_read
= raw_read (s
, p
, to_read
);
479 s
->physical_offset
+= did_read
;
482 nbyte
= did_read
+ nread
;
484 s
->logical_offset
+= nbyte
;
489 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
492 s
->buffer_offset
= s
->logical_offset
;
494 /* Does the data fit into the buffer? As a special case, if the
495 buffer is empty and the request is bigger than BUFFER_SIZE/2,
496 write directly. This avoids the case where the buffer would have
497 to be flushed at every write. */
498 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
499 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
500 && s
->buffer_offset
<= s
->logical_offset
501 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
503 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
504 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
510 /* Flush, and either fill the buffer with the new data, or if
511 the request is bigger than the buffer size, write directly
512 bypassing the buffer. */
514 if (nbyte
<= BUFFER_SIZE
/2)
516 memcpy (s
->buffer
, buf
, nbyte
);
517 s
->buffer_offset
= s
->logical_offset
;
522 if (s
->file_length
!= -1 && s
->physical_offset
!= s
->logical_offset
)
524 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
526 s
->physical_offset
= s
->logical_offset
;
529 nbyte
= raw_write (s
, buf
, nbyte
);
530 s
->physical_offset
+= nbyte
;
533 s
->logical_offset
+= nbyte
;
534 /* Don't increment file_length if the file is non-seekable. */
535 if (s
->file_length
!= -1 && s
->logical_offset
> s
->file_length
)
536 s
->file_length
= s
->logical_offset
;
541 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
548 offset
+= s
->logical_offset
;
551 offset
+= s
->file_length
;
561 s
->logical_offset
= offset
;
566 buf_tell (unix_stream
* s
)
568 return s
->logical_offset
;
572 buf_truncate (unix_stream
* s
, gfc_offset length
)
576 if (buf_flush (s
) != 0)
578 r
= raw_truncate (s
, length
);
580 s
->file_length
= length
;
585 buf_close (unix_stream
* s
)
587 if (buf_flush (s
) != 0)
590 return raw_close (s
);
594 buf_init (unix_stream
* s
)
596 s
->st
.read
= (void *) buf_read
;
597 s
->st
.write
= (void *) buf_write
;
598 s
->st
.seek
= (void *) buf_seek
;
599 s
->st
.tell
= (void *) buf_tell
;
600 s
->st
.trunc
= (void *) buf_truncate
;
601 s
->st
.close
= (void *) buf_close
;
602 s
->st
.flush
= (void *) buf_flush
;
604 s
->buffer
= get_mem (BUFFER_SIZE
);
609 /*********************************************************************
610 memory stream functions - These are used for internal files
612 The idea here is that a single stream structure is created and all
613 requests must be satisfied from it. The location and size of the
614 buffer is the character variable supplied to the READ or WRITE
617 *********************************************************************/
620 mem_alloc_r (stream
* strm
, int * len
)
622 unix_stream
* s
= (unix_stream
*) strm
;
624 gfc_offset where
= s
->logical_offset
;
626 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
629 n
= s
->buffer_offset
+ s
->active
- where
;
633 s
->logical_offset
= where
+ *len
;
635 return s
->buffer
+ (where
- s
->buffer_offset
);
640 mem_alloc_r4 (stream
* strm
, int * len
)
642 unix_stream
* s
= (unix_stream
*) strm
;
644 gfc_offset where
= s
->logical_offset
;
646 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
649 n
= s
->buffer_offset
+ s
->active
- where
;
653 s
->logical_offset
= where
+ *len
;
655 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
660 mem_alloc_w (stream
* strm
, int * len
)
662 unix_stream
* s
= (unix_stream
*) strm
;
664 gfc_offset where
= s
->logical_offset
;
668 if (where
< s
->buffer_offset
)
671 if (m
> s
->file_length
)
674 s
->logical_offset
= m
;
676 return s
->buffer
+ (where
- s
->buffer_offset
);
681 mem_alloc_w4 (stream
* strm
, int * len
)
683 unix_stream
* s
= (unix_stream
*) strm
;
685 gfc_offset where
= s
->logical_offset
;
686 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
690 if (where
< s
->buffer_offset
)
693 if (m
> s
->file_length
)
696 s
->logical_offset
= m
;
697 return &result
[where
- s
->buffer_offset
];
701 /* Stream read function for character(kine=1) internal units. */
704 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
709 p
= mem_alloc_r (s
, &nb
);
720 /* Stream read function for chracter(kind=4) internal units. */
723 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
728 p
= mem_alloc_r (s
, &nb
);
739 /* Stream write function for character(kind=1) internal units. */
742 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
747 p
= mem_alloc_w (s
, &nb
);
758 /* Stream write function for character(kind=4) internal units. */
761 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
766 p
= mem_alloc_w4 (s
, &nw
);
770 *p
++ = (gfc_char4_t
) *((char *) buf
);
779 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
781 unix_stream
* s
= (unix_stream
*) strm
;
787 offset
+= s
->logical_offset
;
790 offset
+= s
->file_length
;
796 /* Note that for internal array I/O it's actually possible to have a
797 negative offset, so don't check for that. */
798 if (offset
> s
->file_length
)
804 s
->logical_offset
= offset
;
806 /* Returning < 0 is the error indicator for sseek(), so return 0 if
807 offset is negative. Thus if the return value is 0, the caller
808 has to use stell() to get the real value of logical_offset. */
816 mem_tell (stream
* s
)
818 return ((unix_stream
*)s
)->logical_offset
;
823 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
824 gfc_offset length
__attribute__ ((unused
)))
831 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
838 mem_close (unix_stream
* s
)
847 /*********************************************************************
848 Public functions -- A reimplementation of this module needs to
849 define functional equivalents of the following.
850 *********************************************************************/
852 /* empty_internal_buffer()-- Zero the buffer of Internal file */
855 empty_internal_buffer(stream
*strm
)
857 unix_stream
* s
= (unix_stream
*) strm
;
858 memset(s
->buffer
, ' ', s
->file_length
);
861 /* open_internal()-- Returns a stream structure from a character(kind=1)
865 open_internal (char *base
, int length
, gfc_offset offset
)
869 s
= get_mem (sizeof (unix_stream
));
870 memset (s
, '\0', sizeof (unix_stream
));
873 s
->buffer_offset
= offset
;
875 s
->logical_offset
= 0;
876 s
->active
= s
->file_length
= length
;
878 s
->st
.close
= (void *) mem_close
;
879 s
->st
.seek
= (void *) mem_seek
;
880 s
->st
.tell
= (void *) mem_tell
;
881 s
->st
.trunc
= (void *) mem_truncate
;
882 s
->st
.read
= (void *) mem_read
;
883 s
->st
.write
= (void *) mem_write
;
884 s
->st
.flush
= (void *) mem_flush
;
889 /* open_internal4()-- Returns a stream structure from a character(kind=4)
893 open_internal4 (char *base
, int length
, gfc_offset offset
)
897 s
= get_mem (sizeof (unix_stream
));
898 memset (s
, '\0', sizeof (unix_stream
));
901 s
->buffer_offset
= offset
;
903 s
->logical_offset
= 0;
904 s
->active
= s
->file_length
= length
;
906 s
->st
.close
= (void *) mem_close
;
907 s
->st
.seek
= (void *) mem_seek
;
908 s
->st
.tell
= (void *) mem_tell
;
909 s
->st
.trunc
= (void *) mem_truncate
;
910 s
->st
.read
= (void *) mem_read4
;
911 s
->st
.write
= (void *) mem_write4
;
912 s
->st
.flush
= (void *) mem_flush
;
918 /* fd_to_stream()-- Given an open file descriptor, build a stream
922 fd_to_stream (int fd
, int prot
)
927 s
= get_mem (sizeof (unix_stream
));
928 memset (s
, '\0', sizeof (unix_stream
));
931 s
->buffer_offset
= 0;
932 s
->physical_offset
= 0;
933 s
->logical_offset
= 0;
936 /* Get the current length of the file. */
938 fstat (fd
, &statbuf
);
940 if (lseek (fd
, 0, SEEK_CUR
) == (gfc_offset
) -1)
943 s
->file_length
= S_ISREG (statbuf
.st_mode
) ? statbuf
.st_size
: -1;
945 s
->special_file
= !S_ISREG (statbuf
.st_mode
);
947 if (isatty (s
->fd
) || options
.all_unbuffered
948 ||(options
.unbuffered_preconnected
&&
949 (s
->fd
== STDIN_FILENO
950 || s
->fd
== STDOUT_FILENO
951 || s
->fd
== STDERR_FILENO
)))
960 /* Given the Fortran unit number, convert it to a C file descriptor. */
963 unit_to_fd (int unit
)
968 us
= find_unit (unit
);
972 fd
= ((unix_stream
*) us
->s
)->fd
;
978 /* unpack_filename()-- Given a fortran string and a pointer to a
979 * buffer that is PATH_MAX characters, convert the fortran string to a
980 * C string in the buffer. Returns nonzero if this is not possible. */
983 unpack_filename (char *cstring
, const char *fstring
, int len
)
985 len
= fstrlen (fstring
, len
);
989 memmove (cstring
, fstring
, len
);
996 /* tempfile()-- Generate a temporary filename for a scratch file and
997 * open it. mkstemp() opens the file for reading and writing, but the
998 * library mode prevents anything that is not allowed. The descriptor
999 * is returned, which is -1 on error. The template is pointed to by
1000 * opp->file, which is copied into the unit structure
1001 * and freed later. */
1004 tempfile (st_parameter_open
*opp
)
1006 const char *tempdir
;
1008 const char *slash
= "/";
1011 tempdir
= getenv ("GFORTRAN_TMPDIR");
1013 if (tempdir
== NULL
)
1015 char buffer
[MAX_PATH
+ 1];
1017 ret
= GetTempPath (MAX_PATH
, buffer
);
1018 /* If we are not able to get a temp-directory, we use
1019 current directory. */
1020 if (ret
> MAX_PATH
|| !ret
)
1024 tempdir
= strdup (buffer
);
1027 if (tempdir
== NULL
)
1028 tempdir
= getenv ("TMP");
1029 if (tempdir
== NULL
)
1030 tempdir
= getenv ("TEMP");
1031 if (tempdir
== NULL
)
1032 tempdir
= DEFAULT_TEMPDIR
;
1034 /* Check for special case that tempdir contains slash
1035 or backslash at end. */
1036 if (*tempdir
== 0 || tempdir
[strlen (tempdir
) - 1] == '/'
1038 || tempdir
[strlen (tempdir
) - 1] == '\\'
1043 template = get_mem (strlen (tempdir
) + 20);
1046 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir
, slash
);
1048 fd
= mkstemp (template);
1050 #else /* HAVE_MKSTEMP */
1054 sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir
, slash
);
1055 if (!mktemp (template))
1057 #if defined(HAVE_CRLF) && defined(O_BINARY)
1058 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
| O_BINARY
,
1059 S_IREAD
| S_IWRITE
);
1061 fd
= open (template, O_RDWR
| O_CREAT
| O_EXCL
, S_IREAD
| S_IWRITE
);
1064 while (fd
== -1 && errno
== EEXIST
);
1065 #endif /* HAVE_MKSTEMP */
1071 opp
->file
= template;
1072 opp
->file_len
= strlen (template); /* Don't include trailing nul */
1079 /* regular_file()-- Open a regular file.
1080 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1081 * unless an error occurs.
1082 * Returns the descriptor, which is less than zero on error. */
1085 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1087 char path
[PATH_MAX
+ 1];
1093 if (unpack_filename (path
, opp
->file
, opp
->file_len
))
1095 errno
= ENOENT
; /* Fake an OS error */
1100 if (opp
->file_len
== 7)
1102 if (strncmp (path
, "CONOUT$", 7) == 0
1103 || strncmp (path
, "CONERR$", 7) == 0)
1105 fd
= open ("/dev/conout", O_WRONLY
);
1106 flags
->action
= ACTION_WRITE
;
1111 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1113 fd
= open ("/dev/conin", O_RDONLY
);
1114 flags
->action
= ACTION_READ
;
1121 if (opp
->file_len
== 7)
1123 if (strncmp (path
, "CONOUT$", 7) == 0
1124 || strncmp (path
, "CONERR$", 7) == 0)
1126 fd
= open ("CONOUT$", O_WRONLY
);
1127 flags
->action
= ACTION_WRITE
;
1132 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1134 fd
= open ("CONIN$", O_RDONLY
);
1135 flags
->action
= ACTION_READ
;
1142 switch (flags
->action
)
1152 case ACTION_READWRITE
:
1153 case ACTION_UNSPECIFIED
:
1158 internal_error (&opp
->common
, "regular_file(): Bad action");
1161 switch (flags
->status
)
1164 crflag
= O_CREAT
| O_EXCL
;
1167 case STATUS_OLD
: /* open will fail if the file does not exist*/
1171 case STATUS_UNKNOWN
:
1172 case STATUS_SCRATCH
:
1176 case STATUS_REPLACE
:
1177 crflag
= O_CREAT
| O_TRUNC
;
1181 internal_error (&opp
->common
, "regular_file(): Bad status");
1184 /* rwflag |= O_LARGEFILE; */
1186 #if defined(HAVE_CRLF) && defined(O_BINARY)
1190 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1191 fd
= open (path
, rwflag
| crflag
, mode
);
1192 if (flags
->action
!= ACTION_UNSPECIFIED
)
1197 flags
->action
= ACTION_READWRITE
;
1200 if (errno
!= EACCES
&& errno
!= EROFS
)
1203 /* retry for read-only access */
1205 fd
= open (path
, rwflag
| crflag
, mode
);
1208 flags
->action
= ACTION_READ
;
1209 return fd
; /* success */
1212 if (errno
!= EACCES
)
1213 return fd
; /* failure */
1215 /* retry for write-only access */
1217 fd
= open (path
, rwflag
| crflag
, mode
);
1220 flags
->action
= ACTION_WRITE
;
1221 return fd
; /* success */
1223 return fd
; /* failure */
1227 /* open_external()-- Open an external file, unix specific version.
1228 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1229 * Returns NULL on operating system error. */
1232 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1236 if (flags
->status
== STATUS_SCRATCH
)
1238 fd
= tempfile (opp
);
1239 if (flags
->action
== ACTION_UNSPECIFIED
)
1240 flags
->action
= ACTION_READWRITE
;
1242 #if HAVE_UNLINK_OPEN_FILE
1243 /* We can unlink scratch files now and it will go away when closed. */
1250 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1252 fd
= regular_file (opp
, flags
);
1259 switch (flags
->action
)
1269 case ACTION_READWRITE
:
1270 prot
= PROT_READ
| PROT_WRITE
;
1274 internal_error (&opp
->common
, "open_external(): Bad action");
1277 return fd_to_stream (fd
, prot
);
1281 /* input_stream()-- Return a stream pointer to the default input stream.
1282 * Called on initialization. */
1287 return fd_to_stream (STDIN_FILENO
, PROT_READ
);
1291 /* output_stream()-- Return a stream pointer to the default output stream.
1292 * Called on initialization. */
1295 output_stream (void)
1299 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1300 setmode (STDOUT_FILENO
, O_BINARY
);
1303 s
= fd_to_stream (STDOUT_FILENO
, PROT_WRITE
);
1308 /* error_stream()-- Return a stream pointer to the default error stream.
1309 * Called on initialization. */
1316 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1317 setmode (STDERR_FILENO
, O_BINARY
);
1320 s
= fd_to_stream (STDERR_FILENO
, PROT_WRITE
);
1325 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1326 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1327 is big enough to completely fill a 80x25 terminal, so it shuld be
1328 OK. We use a direct write() because it is simpler and least likely
1329 to be clobbered by memory corruption. Writing an error message
1330 longer than that is an error. */
1332 #define ST_VPRINTF_SIZE 2048
1335 st_vprintf (const char *format
, va_list ap
)
1337 static char buffer
[ST_VPRINTF_SIZE
];
1341 fd
= options
.use_stderr
? STDERR_FILENO
: STDOUT_FILENO
;
1342 #ifdef HAVE_VSNPRINTF
1343 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
1345 written
= vsprintf(buffer
, format
, ap
);
1347 if (written
>= ST_VPRINTF_SIZE
-1)
1349 /* The error message was longer than our buffer. Ouch. Because
1350 we may have messed up things badly, report the error and
1352 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1353 write (fd
, buffer
, ST_VPRINTF_SIZE
-1);
1354 write (fd
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
1356 #undef ERROR_MESSAGE
1361 written
= write (fd
, buffer
, written
);
1365 /* st_printf()-- printf() function for error output. This just calls
1366 st_vprintf() to do the actual work. */
1369 st_printf (const char *format
, ...)
1373 va_start (ap
, format
);
1374 written
= st_vprintf(format
, ap
);
1380 /* compare_file_filename()-- Given an open stream and a fortran string
1381 * that is a filename, figure out if the file is the same as the
1385 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1387 char path
[PATH_MAX
+ 1];
1389 #ifdef HAVE_WORKING_STAT
1397 if (unpack_filename (path
, name
, len
))
1398 return 0; /* Can't be the same */
1400 /* If the filename doesn't exist, then there is no match with the
1403 if (stat (path
, &st1
) < 0)
1406 #ifdef HAVE_WORKING_STAT
1407 fstat (((unix_stream
*) (u
->s
))->fd
, &st2
);
1408 return (st1
.st_dev
== st2
.st_dev
) && (st1
.st_ino
== st2
.st_ino
);
1412 /* We try to match files by a unique ID. On some filesystems (network
1413 fs and FAT), we can't generate this unique ID, and will simply compare
1415 id1
= id_from_path (path
);
1416 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1418 return (id1
== id2
);
1421 if (len
!= u
->file_len
)
1423 return (memcmp(path
, u
->file
, len
) == 0);
1428 #ifdef HAVE_WORKING_STAT
1429 # define FIND_FILE0_DECL gfstat_t *st
1430 # define FIND_FILE0_ARGS st
1432 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1433 # define FIND_FILE0_ARGS id, file, file_len
1436 /* find_file0()-- Recursive work function for find_file() */
1439 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1442 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1449 #ifdef HAVE_WORKING_STAT
1451 && fstat (((unix_stream
*) u
->s
)->fd
, &st
[1]) >= 0 &&
1452 st
[0].st_dev
== st
[1].st_dev
&& st
[0].st_ino
== st
[1].st_ino
)
1456 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1463 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1467 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1471 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1479 /* find_file()-- Take the current filename and see if there is a unit
1480 * that has the file already open. Returns a pointer to the unit if so. */
1483 find_file (const char *file
, gfc_charlen_type file_len
)
1485 char path
[PATH_MAX
+ 1];
1488 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1492 if (unpack_filename (path
, file
, file_len
))
1495 if (stat (path
, &st
[0]) < 0)
1498 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1499 id
= id_from_path (path
);
1502 __gthread_mutex_lock (&unit_lock
);
1504 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1508 if (! __gthread_mutex_trylock (&u
->lock
))
1510 /* assert (u->closed == 0); */
1511 __gthread_mutex_unlock (&unit_lock
);
1515 inc_waiting_locked (u
);
1517 __gthread_mutex_unlock (&unit_lock
);
1520 __gthread_mutex_lock (&u
->lock
);
1523 __gthread_mutex_lock (&unit_lock
);
1524 __gthread_mutex_unlock (&u
->lock
);
1525 if (predec_waiting_locked (u
) == 0)
1530 dec_waiting_unlocked (u
);
1536 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1540 if (u
->unit_number
> min_unit
)
1542 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1546 if (u
->unit_number
>= min_unit
)
1548 if (__gthread_mutex_trylock (&u
->lock
))
1552 __gthread_mutex_unlock (&u
->lock
);
1560 flush_all_units (void)
1565 __gthread_mutex_lock (&unit_lock
);
1568 u
= flush_all_units_1 (unit_root
, min_unit
);
1570 inc_waiting_locked (u
);
1571 __gthread_mutex_unlock (&unit_lock
);
1575 __gthread_mutex_lock (&u
->lock
);
1577 min_unit
= u
->unit_number
+ 1;
1582 __gthread_mutex_lock (&unit_lock
);
1583 __gthread_mutex_unlock (&u
->lock
);
1584 (void) predec_waiting_locked (u
);
1588 __gthread_mutex_lock (&unit_lock
);
1589 __gthread_mutex_unlock (&u
->lock
);
1590 if (predec_waiting_locked (u
) == 0)
1598 /* delete_file()-- Given a unit structure, delete the file associated
1599 * with the unit. Returns nonzero if something went wrong. */
1602 delete_file (gfc_unit
* u
)
1604 char path
[PATH_MAX
+ 1];
1606 if (unpack_filename (path
, u
->file
, u
->file_len
))
1607 { /* Shouldn't be possible */
1612 return unlink (path
);
1616 /* file_exists()-- Returns nonzero if the current filename exists on
1620 file_exists (const char *file
, gfc_charlen_type file_len
)
1622 char path
[PATH_MAX
+ 1];
1624 if (unpack_filename (path
, file
, file_len
))
1627 return !(access (path
, F_OK
));
1631 /* file_size()-- Returns the size of the file. */
1634 file_size (const char *file
, gfc_charlen_type file_len
)
1636 char path
[PATH_MAX
+ 1];
1639 if (unpack_filename (path
, file
, file_len
))
1642 if (stat (path
, &statbuf
) < 0)
1645 return (GFC_IO_INT
) statbuf
.st_size
;
1648 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1650 /* inquire_sequential()-- Given a fortran string, determine if the
1651 * file is suitable for sequential access. Returns a C-style
1655 inquire_sequential (const char *string
, int len
)
1657 char path
[PATH_MAX
+ 1];
1660 if (string
== NULL
||
1661 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1664 if (S_ISREG (statbuf
.st_mode
) ||
1665 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1668 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1675 /* inquire_direct()-- Given a fortran string, determine if the file is
1676 * suitable for direct access. Returns a C-style string. */
1679 inquire_direct (const char *string
, int len
)
1681 char path
[PATH_MAX
+ 1];
1684 if (string
== NULL
||
1685 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1688 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1691 if (S_ISDIR (statbuf
.st_mode
) ||
1692 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1699 /* inquire_formatted()-- Given a fortran string, determine if the file
1700 * is suitable for formatted form. Returns a C-style string. */
1703 inquire_formatted (const char *string
, int len
)
1705 char path
[PATH_MAX
+ 1];
1708 if (string
== NULL
||
1709 unpack_filename (path
, string
, len
) || stat (path
, &statbuf
) < 0)
1712 if (S_ISREG (statbuf
.st_mode
) ||
1713 S_ISBLK (statbuf
.st_mode
) ||
1714 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1717 if (S_ISDIR (statbuf
.st_mode
))
1724 /* inquire_unformatted()-- Given a fortran string, determine if the file
1725 * is suitable for unformatted form. Returns a C-style string. */
1728 inquire_unformatted (const char *string
, int len
)
1730 return inquire_formatted (string
, len
);
1734 /* inquire_access()-- Given a fortran string, determine if the file is
1735 * suitable for access. */
1738 inquire_access (const char *string
, int len
, int mode
)
1740 char path
[PATH_MAX
+ 1];
1742 if (string
== NULL
|| unpack_filename (path
, string
, len
) ||
1743 access (path
, mode
) < 0)
1750 /* inquire_read()-- Given a fortran string, determine if the file is
1751 * suitable for READ access. */
1754 inquire_read (const char *string
, int len
)
1756 return inquire_access (string
, len
, R_OK
);
1760 /* inquire_write()-- Given a fortran string, determine if the file is
1761 * suitable for READ access. */
1764 inquire_write (const char *string
, int len
)
1766 return inquire_access (string
, len
, W_OK
);
1770 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1771 * suitable for read and write access. */
1774 inquire_readwrite (const char *string
, int len
)
1776 return inquire_access (string
, len
, R_OK
| W_OK
);
1780 /* file_length()-- Return the file length in bytes, -1 if unknown */
1783 file_length (stream
* s
)
1785 gfc_offset curr
, end
;
1786 if (!is_seekable (s
))
1791 end
= sseek (s
, 0, SEEK_END
);
1792 sseek (s
, curr
, SEEK_SET
);
1797 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1801 is_seekable (stream
*s
)
1803 /* By convention, if file_length == -1, the file is not
1805 return ((unix_stream
*) s
)->file_length
!=-1;
1809 /* is_special()-- Return nonzero if the stream is not a regular file. */
1812 is_special (stream
*s
)
1814 return ((unix_stream
*) s
)->special_file
;
1819 stream_isatty (stream
*s
)
1821 return isatty (((unix_stream
*) s
)->fd
);
1825 stream_ttyname (stream
*s
__attribute__ ((unused
)))
1828 return ttyname (((unix_stream
*) s
)->fd
);
1835 /* How files are stored: This is an operating-system specific issue,
1836 and therefore belongs here. There are three cases to consider.
1839 Records are written as block of bytes corresponding to the record
1840 length of the file. This goes for both formatted and unformatted
1841 records. Positioning is done explicitly for each data transfer,
1842 so positioning is not much of an issue.
1844 Sequential Formatted:
1845 Records are separated by newline characters. The newline character
1846 is prohibited from appearing in a string. If it does, this will be
1847 messed up on the next read. End of file is also the end of a record.
1849 Sequential Unformatted:
1850 In this case, we are merely copying bytes to and from main storage,
1851 yet we need to keep track of varying record lengths. We adopt
1852 the solution used by f2c. Each record contains a pair of length
1855 Length of record n in bytes
1857 Length of record n in bytes
1859 Length of record n+1 in bytes
1861 Length of record n+1 in bytes
1863 The length is stored at the end of a record to allow backspacing to the
1864 previous record. Between data transfer statements, the file pointer
1865 is left pointing to the first length of the current record.
1867 ENDFILE records are never explicitly stored.