xref: /netbsd-src/external/gpl3/gcc/dist/libgfortran/io/unix.c (revision b1e838363e3c6fc78a55519254d99869742dd33c)
1*b1e83836Smrg /* Copyright (C) 2002-2022 Free Software Foundation, Inc.
2181254a7Smrg    Contributed by Andy Vaught
3181254a7Smrg    F2003 I/O support contributed by Jerry DeLisle
4181254a7Smrg 
5181254a7Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6181254a7Smrg 
7181254a7Smrg Libgfortran is free software; you can redistribute it and/or modify
8181254a7Smrg it under the terms of the GNU General Public License as published by
9181254a7Smrg the Free Software Foundation; either version 3, or (at your option)
10181254a7Smrg any later version.
11181254a7Smrg 
12181254a7Smrg Libgfortran is distributed in the hope that it will be useful,
13181254a7Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14181254a7Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15181254a7Smrg GNU General Public License for more details.
16181254a7Smrg 
17181254a7Smrg Under Section 7 of GPL version 3, you are granted additional
18181254a7Smrg permissions described in the GCC Runtime Library Exception, version
19181254a7Smrg 3.1, as published by the Free Software Foundation.
20181254a7Smrg 
21181254a7Smrg You should have received a copy of the GNU General Public License and
22181254a7Smrg a copy of the GCC Runtime Library Exception along with this program;
23181254a7Smrg see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24181254a7Smrg <http://www.gnu.org/licenses/>.  */
25181254a7Smrg 
26181254a7Smrg /* Unix stream I/O module */
27181254a7Smrg 
28181254a7Smrg #include "io.h"
29181254a7Smrg #include "unix.h"
30181254a7Smrg #include "async.h"
31181254a7Smrg #include <limits.h>
32181254a7Smrg 
33181254a7Smrg #ifdef HAVE_UNISTD_H
34181254a7Smrg #include <unistd.h>
35181254a7Smrg #endif
36181254a7Smrg 
37181254a7Smrg #include <sys/stat.h>
38181254a7Smrg #include <fcntl.h>
39181254a7Smrg 
40181254a7Smrg #include <string.h>
41181254a7Smrg #include <errno.h>
42181254a7Smrg 
43181254a7Smrg 
44181254a7Smrg /* For mingw, we don't identify files by their inode number, but by a
45181254a7Smrg    64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
46181254a7Smrg #ifdef __MINGW32__
47181254a7Smrg 
48181254a7Smrg #define WIN32_LEAN_AND_MEAN
49181254a7Smrg #include <windows.h>
50181254a7Smrg 
51181254a7Smrg #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
52181254a7Smrg #undef lseek
53181254a7Smrg #define lseek _lseeki64
54181254a7Smrg #undef fstat
55181254a7Smrg #define fstat _fstati64
56181254a7Smrg #undef stat
57181254a7Smrg #define stat _stati64
58181254a7Smrg #endif
59181254a7Smrg 
60181254a7Smrg #ifndef HAVE_WORKING_STAT
61181254a7Smrg static uint64_t
id_from_handle(HANDLE hFile)62181254a7Smrg id_from_handle (HANDLE hFile)
63181254a7Smrg {
64181254a7Smrg   BY_HANDLE_FILE_INFORMATION FileInformation;
65181254a7Smrg 
66181254a7Smrg   if (hFile == INVALID_HANDLE_VALUE)
67181254a7Smrg       return 0;
68181254a7Smrg 
69181254a7Smrg   memset (&FileInformation, 0, sizeof(FileInformation));
70181254a7Smrg   if (!GetFileInformationByHandle (hFile, &FileInformation))
71181254a7Smrg     return 0;
72181254a7Smrg 
73181254a7Smrg   return ((uint64_t) FileInformation.nFileIndexLow)
74181254a7Smrg 	 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
75181254a7Smrg }
76181254a7Smrg 
77181254a7Smrg 
78181254a7Smrg static uint64_t
id_from_path(const char * path)79181254a7Smrg id_from_path (const char *path)
80181254a7Smrg {
81181254a7Smrg   HANDLE hFile;
82181254a7Smrg   uint64_t res;
83181254a7Smrg 
84181254a7Smrg   if (!path || !*path || access (path, F_OK))
85181254a7Smrg     return (uint64_t) -1;
86181254a7Smrg 
87181254a7Smrg   hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
88181254a7Smrg 		      FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
89181254a7Smrg 		      NULL);
90181254a7Smrg   res = id_from_handle (hFile);
91181254a7Smrg   CloseHandle (hFile);
92181254a7Smrg   return res;
93181254a7Smrg }
94181254a7Smrg 
95181254a7Smrg 
96181254a7Smrg static uint64_t
id_from_fd(const int fd)97181254a7Smrg id_from_fd (const int fd)
98181254a7Smrg {
99181254a7Smrg   return id_from_handle ((HANDLE) _get_osfhandle (fd));
100181254a7Smrg }
101181254a7Smrg 
102181254a7Smrg #endif /* HAVE_WORKING_STAT */
103181254a7Smrg 
104181254a7Smrg 
105181254a7Smrg /* On mingw, we don't use umask in tempfile_open(), because it
106181254a7Smrg    doesn't support the user/group/other-based permissions.  */
107181254a7Smrg #undef HAVE_UMASK
108181254a7Smrg 
109181254a7Smrg #endif /* __MINGW32__ */
110181254a7Smrg 
111181254a7Smrg 
112181254a7Smrg /* These flags aren't defined on all targets (mingw32), so provide them
113181254a7Smrg    here.  */
114181254a7Smrg #ifndef S_IRGRP
115181254a7Smrg #define S_IRGRP 0
116181254a7Smrg #endif
117181254a7Smrg 
118181254a7Smrg #ifndef S_IWGRP
119181254a7Smrg #define S_IWGRP 0
120181254a7Smrg #endif
121181254a7Smrg 
122181254a7Smrg #ifndef S_IROTH
123181254a7Smrg #define S_IROTH 0
124181254a7Smrg #endif
125181254a7Smrg 
126181254a7Smrg #ifndef S_IWOTH
127181254a7Smrg #define S_IWOTH 0
128181254a7Smrg #endif
129181254a7Smrg 
130181254a7Smrg 
131181254a7Smrg #ifndef HAVE_ACCESS
132181254a7Smrg 
133181254a7Smrg #ifndef W_OK
134181254a7Smrg #define W_OK 2
135181254a7Smrg #endif
136181254a7Smrg 
137181254a7Smrg #ifndef R_OK
138181254a7Smrg #define R_OK 4
139181254a7Smrg #endif
140181254a7Smrg 
141181254a7Smrg #ifndef F_OK
142181254a7Smrg #define F_OK 0
143181254a7Smrg #endif
144181254a7Smrg 
145181254a7Smrg /* Fallback implementation of access() on systems that don't have it.
146181254a7Smrg    Only modes R_OK, W_OK and F_OK are used in this file.  */
147181254a7Smrg 
148181254a7Smrg static int
fallback_access(const char * path,int mode)149181254a7Smrg fallback_access (const char *path, int mode)
150181254a7Smrg {
151181254a7Smrg   int fd;
152181254a7Smrg 
153181254a7Smrg   if (mode & R_OK)
154181254a7Smrg     {
155181254a7Smrg       if ((fd = open (path, O_RDONLY)) < 0)
156181254a7Smrg 	return -1;
157181254a7Smrg       else
158181254a7Smrg 	close (fd);
159181254a7Smrg     }
160181254a7Smrg 
161181254a7Smrg   if (mode & W_OK)
162181254a7Smrg     {
163181254a7Smrg       if ((fd = open (path, O_WRONLY)) < 0)
164181254a7Smrg 	return -1;
165181254a7Smrg       else
166181254a7Smrg 	close (fd);
167181254a7Smrg     }
168181254a7Smrg 
169181254a7Smrg   if (mode == F_OK)
170181254a7Smrg     {
171181254a7Smrg       struct stat st;
172181254a7Smrg       return stat (path, &st);
173181254a7Smrg     }
174181254a7Smrg 
175181254a7Smrg   return 0;
176181254a7Smrg }
177181254a7Smrg 
178181254a7Smrg #undef access
179181254a7Smrg #define access fallback_access
180181254a7Smrg #endif
181181254a7Smrg 
182181254a7Smrg 
183181254a7Smrg /* Fallback directory for creating temporary files.  P_tmpdir is
184181254a7Smrg    defined on many POSIX platforms.  */
185181254a7Smrg #ifndef P_tmpdir
186181254a7Smrg #ifdef _P_tmpdir
187181254a7Smrg #define P_tmpdir _P_tmpdir  /* MinGW */
188181254a7Smrg #else
189181254a7Smrg #define P_tmpdir "/tmp"
190181254a7Smrg #endif
191181254a7Smrg #endif
192181254a7Smrg 
193181254a7Smrg 
194181254a7Smrg /* Unix and internal stream I/O module */
195181254a7Smrg 
196181254a7Smrg static const int FORMATTED_BUFFER_SIZE_DEFAULT = 8192;
197181254a7Smrg static const int UNFORMATTED_BUFFER_SIZE_DEFAULT = 128*1024;
198181254a7Smrg 
199181254a7Smrg typedef struct
200181254a7Smrg {
201181254a7Smrg   stream st;
202181254a7Smrg 
203181254a7Smrg   gfc_offset buffer_offset;	/* File offset of the start of the buffer */
204181254a7Smrg   gfc_offset physical_offset;	/* Current physical file offset */
205181254a7Smrg   gfc_offset logical_offset;	/* Current logical file offset */
206181254a7Smrg   gfc_offset file_length;	/* Length of the file. */
207181254a7Smrg 
208181254a7Smrg   char *buffer;                 /* Pointer to the buffer.  */
209181254a7Smrg   ssize_t buffer_size;           /* Length of the buffer.  */
210181254a7Smrg   int fd;                       /* The POSIX file descriptor.  */
211181254a7Smrg 
212181254a7Smrg   int active;			/* Length of valid bytes in the buffer */
213181254a7Smrg 
214181254a7Smrg   int ndirty;			/* Dirty bytes starting at buffer_offset */
215181254a7Smrg 
216181254a7Smrg   /* Cached stat(2) values.  */
217181254a7Smrg   dev_t st_dev;
218181254a7Smrg   ino_t st_ino;
219181254a7Smrg 
220181254a7Smrg   bool unbuffered;  /* Buffer should be flushed after each I/O statement.  */
221181254a7Smrg }
222181254a7Smrg unix_stream;
223181254a7Smrg 
224181254a7Smrg 
225181254a7Smrg /* fix_fd()-- Given a file descriptor, make sure it is not one of the
226181254a7Smrg    standard descriptors, returning a non-standard descriptor.  If the
227181254a7Smrg    user specifies that system errors should go to standard output,
228181254a7Smrg    then closes standard output, we don't want the system errors to a
229181254a7Smrg    file that has been given file descriptor 1 or 0.  We want to send
230181254a7Smrg    the error to the invalid descriptor. */
231181254a7Smrg 
232181254a7Smrg static int
fix_fd(int fd)233181254a7Smrg fix_fd (int fd)
234181254a7Smrg {
235181254a7Smrg #ifdef HAVE_DUP
236181254a7Smrg   int input, output, error;
237181254a7Smrg 
238181254a7Smrg   input = output = error = 0;
239181254a7Smrg 
240181254a7Smrg   /* Unix allocates the lowest descriptors first, so a loop is not
241181254a7Smrg      required, but this order is. */
242181254a7Smrg   if (fd == STDIN_FILENO)
243181254a7Smrg     {
244181254a7Smrg       fd = dup (fd);
245181254a7Smrg       input = 1;
246181254a7Smrg     }
247181254a7Smrg   if (fd == STDOUT_FILENO)
248181254a7Smrg     {
249181254a7Smrg       fd = dup (fd);
250181254a7Smrg       output = 1;
251181254a7Smrg     }
252181254a7Smrg   if (fd == STDERR_FILENO)
253181254a7Smrg     {
254181254a7Smrg       fd = dup (fd);
255181254a7Smrg       error = 1;
256181254a7Smrg     }
257181254a7Smrg 
258181254a7Smrg   if (input)
259181254a7Smrg     close (STDIN_FILENO);
260181254a7Smrg   if (output)
261181254a7Smrg     close (STDOUT_FILENO);
262181254a7Smrg   if (error)
263181254a7Smrg     close (STDERR_FILENO);
264181254a7Smrg #endif
265181254a7Smrg 
266181254a7Smrg   return fd;
267181254a7Smrg }
268181254a7Smrg 
269181254a7Smrg 
270181254a7Smrg /* If the stream corresponds to a preconnected unit, we flush the
271181254a7Smrg    corresponding C stream.  This is bugware for mixed C-Fortran codes
272181254a7Smrg    where the C code doesn't flush I/O before returning.  */
273181254a7Smrg void
flush_if_preconnected(stream * s)274181254a7Smrg flush_if_preconnected (stream *s)
275181254a7Smrg {
276181254a7Smrg   int fd;
277181254a7Smrg 
278181254a7Smrg   fd = ((unix_stream *) s)->fd;
279181254a7Smrg   if (fd == STDIN_FILENO)
280181254a7Smrg     fflush (stdin);
281181254a7Smrg   else if (fd == STDOUT_FILENO)
282181254a7Smrg     fflush (stdout);
283181254a7Smrg   else if (fd == STDERR_FILENO)
284181254a7Smrg     fflush (stderr);
285181254a7Smrg }
286181254a7Smrg 
287181254a7Smrg 
288181254a7Smrg /********************************************************************
289181254a7Smrg Raw I/O functions (read, write, seek, tell, truncate, close).
290181254a7Smrg 
291181254a7Smrg These functions wrap the basic POSIX I/O syscalls. Any deviation in
292181254a7Smrg semantics is a bug, except the following: write restarts in case
293181254a7Smrg of being interrupted by a signal, and as the first argument the
294181254a7Smrg functions take the unix_stream struct rather than an integer file
295181254a7Smrg descriptor. Also, for POSIX read() and write() a nbyte argument larger
296181254a7Smrg than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
297181254a7Smrg than size_t as for POSIX read/write.
298181254a7Smrg *********************************************************************/
299181254a7Smrg 
300181254a7Smrg static int
raw_flush(unix_stream * s)301181254a7Smrg raw_flush (unix_stream *s  __attribute__ ((unused)))
302181254a7Smrg {
303181254a7Smrg   return 0;
304181254a7Smrg }
305181254a7Smrg 
306181254a7Smrg /* Write/read at most 2 GB - 4k chunks at a time. Linux never reads or
307181254a7Smrg    writes more than this, and there are reports that macOS fails for
308181254a7Smrg    larger than 2 GB as well.  */
309181254a7Smrg #define MAX_CHUNK 2147479552
310181254a7Smrg 
311181254a7Smrg static ssize_t
raw_read(unix_stream * s,void * buf,ssize_t nbyte)312181254a7Smrg raw_read (unix_stream *s, void *buf, ssize_t nbyte)
313181254a7Smrg {
314181254a7Smrg   /* For read we can't do I/O in a loop like raw_write does, because
315181254a7Smrg      that will break applications that wait for interactive I/O.  We
316181254a7Smrg      still can loop around EINTR, though.  This however causes a
317181254a7Smrg      problem for large reads which must be chunked, see comment above.
318181254a7Smrg      So assume that if the size is larger than the chunk size, we're
319181254a7Smrg      reading from a file and not the terminal.  */
320181254a7Smrg   if (nbyte <= MAX_CHUNK)
321181254a7Smrg     {
322181254a7Smrg       while (true)
323181254a7Smrg 	{
324181254a7Smrg 	  ssize_t trans = read (s->fd, buf, nbyte);
325181254a7Smrg 	  if (trans == -1 && errno == EINTR)
326181254a7Smrg 	    continue;
327181254a7Smrg 	  return trans;
328181254a7Smrg 	}
329181254a7Smrg     }
330181254a7Smrg   else
331181254a7Smrg     {
332181254a7Smrg       ssize_t bytes_left = nbyte;
333181254a7Smrg       char *buf_st = buf;
334181254a7Smrg       while (bytes_left > 0)
335181254a7Smrg 	{
336181254a7Smrg 	  ssize_t to_read = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
337181254a7Smrg 	  ssize_t trans = read (s->fd, buf_st, to_read);
338181254a7Smrg 	  if (trans == -1)
339181254a7Smrg 	    {
340181254a7Smrg 	      if (errno == EINTR)
341181254a7Smrg 		continue;
342181254a7Smrg 	      else
343181254a7Smrg 		return trans;
344181254a7Smrg 	    }
345181254a7Smrg 	  buf_st += trans;
346181254a7Smrg 	  bytes_left -= trans;
347181254a7Smrg 	}
348181254a7Smrg       return nbyte - bytes_left;
349181254a7Smrg     }
350181254a7Smrg }
351181254a7Smrg 
352181254a7Smrg static ssize_t
raw_write(unix_stream * s,const void * buf,ssize_t nbyte)353181254a7Smrg raw_write (unix_stream *s, const void *buf, ssize_t nbyte)
354181254a7Smrg {
355181254a7Smrg   ssize_t trans, bytes_left;
356181254a7Smrg   char *buf_st;
357181254a7Smrg 
358181254a7Smrg   bytes_left = nbyte;
359181254a7Smrg   buf_st = (char *) buf;
360181254a7Smrg 
361181254a7Smrg   /* We must write in a loop since some systems don't restart system
362181254a7Smrg      calls in case of a signal.  Also some systems might fail outright
363181254a7Smrg      if we try to write more than 2 GB in a single syscall, so chunk
364181254a7Smrg      up large writes.  */
365181254a7Smrg   while (bytes_left > 0)
366181254a7Smrg     {
367181254a7Smrg       ssize_t to_write = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
368181254a7Smrg       trans = write (s->fd, buf_st, to_write);
369181254a7Smrg       if (trans == -1)
370181254a7Smrg 	{
371181254a7Smrg 	  if (errno == EINTR)
372181254a7Smrg 	    continue;
373181254a7Smrg 	  else
374181254a7Smrg 	    return trans;
375181254a7Smrg 	}
376181254a7Smrg       buf_st += trans;
377181254a7Smrg       bytes_left -= trans;
378181254a7Smrg     }
379181254a7Smrg 
380181254a7Smrg   return nbyte - bytes_left;
381181254a7Smrg }
382181254a7Smrg 
383181254a7Smrg static gfc_offset
raw_seek(unix_stream * s,gfc_offset offset,int whence)384181254a7Smrg raw_seek (unix_stream *s, gfc_offset offset, int whence)
385181254a7Smrg {
386181254a7Smrg   while (true)
387181254a7Smrg     {
388181254a7Smrg       gfc_offset off = lseek (s->fd, offset, whence);
389181254a7Smrg       if (off == (gfc_offset) -1 && errno == EINTR)
390181254a7Smrg 	continue;
391181254a7Smrg       return off;
392181254a7Smrg     }
393181254a7Smrg }
394181254a7Smrg 
395181254a7Smrg static gfc_offset
raw_tell(unix_stream * s)396181254a7Smrg raw_tell (unix_stream *s)
397181254a7Smrg {
398181254a7Smrg   while (true)
399181254a7Smrg     {
400181254a7Smrg       gfc_offset off = lseek (s->fd, 0, SEEK_CUR);
401181254a7Smrg       if (off == (gfc_offset) -1 && errno == EINTR)
402181254a7Smrg 	continue;
403181254a7Smrg       return off;
404181254a7Smrg     }
405181254a7Smrg }
406181254a7Smrg 
407181254a7Smrg static gfc_offset
raw_size(unix_stream * s)408181254a7Smrg raw_size (unix_stream *s)
409181254a7Smrg {
410181254a7Smrg   struct stat statbuf;
411181254a7Smrg   if (TEMP_FAILURE_RETRY (fstat (s->fd, &statbuf)) == -1)
412181254a7Smrg     return -1;
413181254a7Smrg   if (S_ISREG (statbuf.st_mode))
414181254a7Smrg     return statbuf.st_size;
415181254a7Smrg   else
416181254a7Smrg     return 0;
417181254a7Smrg }
418181254a7Smrg 
419181254a7Smrg static int
raw_truncate(unix_stream * s,gfc_offset length)420181254a7Smrg raw_truncate (unix_stream *s, gfc_offset length)
421181254a7Smrg {
422181254a7Smrg #ifdef __MINGW32__
423181254a7Smrg   HANDLE h;
424181254a7Smrg   gfc_offset cur;
425181254a7Smrg 
426181254a7Smrg   if (isatty (s->fd))
427181254a7Smrg     {
428181254a7Smrg       errno = EBADF;
429181254a7Smrg       return -1;
430181254a7Smrg     }
431181254a7Smrg   h = (HANDLE) _get_osfhandle (s->fd);
432181254a7Smrg   if (h == INVALID_HANDLE_VALUE)
433181254a7Smrg     {
434181254a7Smrg       errno = EBADF;
435181254a7Smrg       return -1;
436181254a7Smrg     }
437181254a7Smrg   cur = lseek (s->fd, 0, SEEK_CUR);
438181254a7Smrg   if (cur == -1)
439181254a7Smrg     return -1;
440181254a7Smrg   if (lseek (s->fd, length, SEEK_SET) == -1)
441181254a7Smrg     goto error;
442181254a7Smrg   if (!SetEndOfFile (h))
443181254a7Smrg     {
444181254a7Smrg       errno = EBADF;
445181254a7Smrg       goto error;
446181254a7Smrg     }
447181254a7Smrg   if (lseek (s->fd, cur, SEEK_SET) == -1)
448181254a7Smrg     return -1;
449181254a7Smrg   return 0;
450181254a7Smrg  error:
451181254a7Smrg   lseek (s->fd, cur, SEEK_SET);
452181254a7Smrg   return -1;
453181254a7Smrg #elif defined HAVE_FTRUNCATE
454181254a7Smrg   if (TEMP_FAILURE_RETRY (ftruncate (s->fd, length)) == -1)
455181254a7Smrg     return -1;
456181254a7Smrg   return 0;
457181254a7Smrg #elif defined HAVE_CHSIZE
458181254a7Smrg   return chsize (s->fd, length);
459181254a7Smrg #else
460181254a7Smrg   runtime_error ("required ftruncate or chsize support not present");
461181254a7Smrg   return -1;
462181254a7Smrg #endif
463181254a7Smrg }
464181254a7Smrg 
465181254a7Smrg static int
raw_close(unix_stream * s)466181254a7Smrg raw_close (unix_stream *s)
467181254a7Smrg {
468181254a7Smrg   int retval;
469181254a7Smrg 
470181254a7Smrg   if (s->fd == -1)
471181254a7Smrg     retval = -1;
472181254a7Smrg   else if (s->fd != STDOUT_FILENO
473181254a7Smrg       && s->fd != STDERR_FILENO
474181254a7Smrg       && s->fd != STDIN_FILENO)
475181254a7Smrg     {
476181254a7Smrg       retval = close (s->fd);
477181254a7Smrg       /* close() and EINTR is special, as the file descriptor is
478181254a7Smrg 	 deallocated before doing anything that might cause the
479181254a7Smrg 	 operation to be interrupted. Thus if we get EINTR the best we
480181254a7Smrg 	 can do is ignore it and continue (otherwise if we try again
481181254a7Smrg 	 the file descriptor may have been allocated again to some
482181254a7Smrg 	 other file).  */
483181254a7Smrg       if (retval == -1 && errno == EINTR)
484181254a7Smrg 	retval = errno = 0;
485181254a7Smrg     }
486181254a7Smrg   else
487181254a7Smrg     retval = 0;
488181254a7Smrg   free (s);
489181254a7Smrg   return retval;
490181254a7Smrg }
491181254a7Smrg 
492181254a7Smrg static int
raw_markeor(unix_stream * s)493181254a7Smrg raw_markeor (unix_stream *s __attribute__ ((unused)))
494181254a7Smrg {
495181254a7Smrg   return 0;
496181254a7Smrg }
497181254a7Smrg 
498181254a7Smrg static const struct stream_vtable raw_vtable = {
499181254a7Smrg   .read = (void *) raw_read,
500181254a7Smrg   .write = (void *) raw_write,
501181254a7Smrg   .seek = (void *) raw_seek,
502181254a7Smrg   .tell = (void *) raw_tell,
503181254a7Smrg   .size = (void *) raw_size,
504181254a7Smrg   .trunc = (void *) raw_truncate,
505181254a7Smrg   .close = (void *) raw_close,
506181254a7Smrg   .flush = (void *) raw_flush,
507181254a7Smrg   .markeor = (void *) raw_markeor
508181254a7Smrg };
509181254a7Smrg 
510181254a7Smrg static int
raw_init(unix_stream * s)511181254a7Smrg raw_init (unix_stream *s)
512181254a7Smrg {
513181254a7Smrg   s->st.vptr = &raw_vtable;
514181254a7Smrg 
515181254a7Smrg   s->buffer = NULL;
516181254a7Smrg   return 0;
517181254a7Smrg }
518181254a7Smrg 
519181254a7Smrg 
520181254a7Smrg /*********************************************************************
521181254a7Smrg Buffered I/O functions. These functions have the same semantics as the
522181254a7Smrg raw I/O functions above, except that they are buffered in order to
523181254a7Smrg improve performance. The buffer must be flushed when switching from
524181254a7Smrg reading to writing and vice versa.
525181254a7Smrg *********************************************************************/
526181254a7Smrg 
527181254a7Smrg static int
buf_flush(unix_stream * s)528181254a7Smrg buf_flush (unix_stream *s)
529181254a7Smrg {
530181254a7Smrg   int writelen;
531181254a7Smrg 
532181254a7Smrg   /* Flushing in read mode means discarding read bytes.  */
533181254a7Smrg   s->active = 0;
534181254a7Smrg 
535181254a7Smrg   if (s->ndirty == 0)
536181254a7Smrg     return 0;
537181254a7Smrg 
538181254a7Smrg   if (s->physical_offset != s->buffer_offset
539181254a7Smrg       && raw_seek (s, s->buffer_offset, SEEK_SET) < 0)
540181254a7Smrg     return -1;
541181254a7Smrg 
542181254a7Smrg   writelen = raw_write (s, s->buffer, s->ndirty);
543181254a7Smrg 
544181254a7Smrg   s->physical_offset = s->buffer_offset + writelen;
545181254a7Smrg 
546181254a7Smrg   if (s->physical_offset > s->file_length)
547181254a7Smrg       s->file_length = s->physical_offset;
548181254a7Smrg 
549181254a7Smrg   s->ndirty -= writelen;
550181254a7Smrg   if (s->ndirty != 0)
551181254a7Smrg     return -1;
552181254a7Smrg 
553181254a7Smrg   return 0;
554181254a7Smrg }
555181254a7Smrg 
556181254a7Smrg static ssize_t
buf_read(unix_stream * s,void * buf,ssize_t nbyte)557181254a7Smrg buf_read (unix_stream *s, void *buf, ssize_t nbyte)
558181254a7Smrg {
559181254a7Smrg   if (s->active == 0)
560181254a7Smrg     s->buffer_offset = s->logical_offset;
561181254a7Smrg 
562181254a7Smrg   /* Is the data we want in the buffer?  */
563181254a7Smrg   if (s->logical_offset + nbyte <= s->buffer_offset + s->active
564181254a7Smrg       && s->buffer_offset <= s->logical_offset)
565181254a7Smrg     {
566181254a7Smrg       /* When nbyte == 0, buf can be NULL which would lead to undefined
567181254a7Smrg 	 behavior if we called memcpy().  */
568181254a7Smrg       if (nbyte != 0)
569181254a7Smrg 	memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
570181254a7Smrg 		nbyte);
571181254a7Smrg     }
572181254a7Smrg   else
573181254a7Smrg     {
574181254a7Smrg       /* First copy the active bytes if applicable, then read the rest
575181254a7Smrg          either directly or filling the buffer.  */
576181254a7Smrg       char *p;
577181254a7Smrg       int nread = 0;
578181254a7Smrg       ssize_t to_read, did_read;
579181254a7Smrg       gfc_offset new_logical;
580181254a7Smrg 
581181254a7Smrg       p = (char *) buf;
582181254a7Smrg       if (s->logical_offset >= s->buffer_offset
583181254a7Smrg           && s->buffer_offset + s->active >= s->logical_offset)
584181254a7Smrg         {
585181254a7Smrg           nread = s->active - (s->logical_offset - s->buffer_offset);
586181254a7Smrg           memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
587181254a7Smrg                   nread);
588181254a7Smrg           p += nread;
589181254a7Smrg         }
590181254a7Smrg       /* At this point we consider all bytes in the buffer discarded.  */
591181254a7Smrg       to_read = nbyte - nread;
592181254a7Smrg       new_logical = s->logical_offset + nread;
593181254a7Smrg       if (s->physical_offset != new_logical
594181254a7Smrg           && raw_seek (s, new_logical, SEEK_SET) < 0)
595181254a7Smrg         return -1;
596181254a7Smrg       s->buffer_offset = s->physical_offset = new_logical;
597181254a7Smrg       if (to_read <= s->buffer_size/2)
598181254a7Smrg         {
599181254a7Smrg           did_read = raw_read (s, s->buffer, s->buffer_size);
600181254a7Smrg 	  if (likely (did_read >= 0))
601181254a7Smrg 	    {
602181254a7Smrg 	      s->physical_offset += did_read;
603181254a7Smrg 	      s->active = did_read;
604181254a7Smrg 	      did_read = (did_read > to_read) ? to_read : did_read;
605181254a7Smrg 	      memcpy (p, s->buffer, did_read);
606181254a7Smrg 	    }
607181254a7Smrg 	  else
608181254a7Smrg 	    return did_read;
609181254a7Smrg         }
610181254a7Smrg       else
611181254a7Smrg         {
612181254a7Smrg           did_read = raw_read (s, p, to_read);
613181254a7Smrg 	  if (likely (did_read >= 0))
614181254a7Smrg 	    {
615181254a7Smrg 	      s->physical_offset += did_read;
616181254a7Smrg 	      s->active = 0;
617181254a7Smrg 	    }
618181254a7Smrg 	  else
619181254a7Smrg 	    return did_read;
620181254a7Smrg         }
621181254a7Smrg       nbyte = did_read + nread;
622181254a7Smrg     }
623181254a7Smrg   s->logical_offset += nbyte;
624181254a7Smrg   return nbyte;
625181254a7Smrg }
626181254a7Smrg 
627181254a7Smrg static ssize_t
buf_write(unix_stream * s,const void * buf,ssize_t nbyte)628181254a7Smrg buf_write (unix_stream *s, const void *buf, ssize_t nbyte)
629181254a7Smrg {
630181254a7Smrg   if (nbyte == 0)
631181254a7Smrg     return 0;
632181254a7Smrg 
633181254a7Smrg   if (s->ndirty == 0)
634181254a7Smrg     s->buffer_offset = s->logical_offset;
635181254a7Smrg 
636181254a7Smrg   /* Does the data fit into the buffer?  As a special case, if the
637181254a7Smrg      buffer is empty and the request is bigger than s->buffer_size/2,
638181254a7Smrg      write directly. This avoids the case where the buffer would have
639181254a7Smrg      to be flushed at every write.  */
640181254a7Smrg   if (!(s->ndirty == 0 && nbyte > s->buffer_size/2)
641181254a7Smrg       && s->logical_offset + nbyte <= s->buffer_offset + s->buffer_size
642181254a7Smrg       && s->buffer_offset <= s->logical_offset
643181254a7Smrg       && s->buffer_offset + s->ndirty >= s->logical_offset)
644181254a7Smrg     {
645181254a7Smrg       memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
646181254a7Smrg       int nd = (s->logical_offset - s->buffer_offset) + nbyte;
647181254a7Smrg       if (nd > s->ndirty)
648181254a7Smrg         s->ndirty = nd;
649181254a7Smrg     }
650181254a7Smrg   else
651181254a7Smrg     {
652181254a7Smrg       /* Flush, and either fill the buffer with the new data, or if
653181254a7Smrg          the request is bigger than the buffer size, write directly
654181254a7Smrg          bypassing the buffer.  */
655181254a7Smrg       buf_flush (s);
656181254a7Smrg       if (nbyte <= s->buffer_size/2)
657181254a7Smrg         {
658181254a7Smrg           memcpy (s->buffer, buf, nbyte);
659181254a7Smrg           s->buffer_offset = s->logical_offset;
660181254a7Smrg           s->ndirty += nbyte;
661181254a7Smrg         }
662181254a7Smrg       else
663181254a7Smrg 	{
664181254a7Smrg 	  if (s->physical_offset != s->logical_offset)
665181254a7Smrg 	    {
666181254a7Smrg 	      if (raw_seek (s, s->logical_offset, SEEK_SET) < 0)
667181254a7Smrg 		return -1;
668181254a7Smrg 	      s->physical_offset = s->logical_offset;
669181254a7Smrg 	    }
670181254a7Smrg 
671181254a7Smrg 	  nbyte = raw_write (s, buf, nbyte);
672181254a7Smrg 	  s->physical_offset += nbyte;
673181254a7Smrg 	}
674181254a7Smrg     }
675181254a7Smrg   s->logical_offset += nbyte;
676181254a7Smrg   if (s->logical_offset > s->file_length)
677181254a7Smrg     s->file_length = s->logical_offset;
678181254a7Smrg   return nbyte;
679181254a7Smrg }
680181254a7Smrg 
681181254a7Smrg 
682181254a7Smrg /* "Unbuffered" really means I/O statement buffering. For formatted
683181254a7Smrg    I/O, the fbuf manages this, and then uses raw I/O. For unformatted
684181254a7Smrg    I/O, buffered I/O is used, and the buffer is flushed at the end of
685181254a7Smrg    each I/O statement, where this function is called.  Alternatively,
686181254a7Smrg    the buffer is flushed at the end of the record if the buffer is
687181254a7Smrg    more than half full; this prevents needless seeking back and forth
688181254a7Smrg    when writing sequential unformatted.  */
689181254a7Smrg 
690181254a7Smrg static int
buf_markeor(unix_stream * s)691181254a7Smrg buf_markeor (unix_stream *s)
692181254a7Smrg {
693181254a7Smrg   if (s->unbuffered || s->ndirty >= s->buffer_size / 2)
694181254a7Smrg     return buf_flush (s);
695181254a7Smrg   return 0;
696181254a7Smrg }
697181254a7Smrg 
698181254a7Smrg static gfc_offset
buf_seek(unix_stream * s,gfc_offset offset,int whence)699181254a7Smrg buf_seek (unix_stream *s, gfc_offset offset, int whence)
700181254a7Smrg {
701181254a7Smrg   switch (whence)
702181254a7Smrg     {
703181254a7Smrg     case SEEK_SET:
704181254a7Smrg       break;
705181254a7Smrg     case SEEK_CUR:
706181254a7Smrg       offset += s->logical_offset;
707181254a7Smrg       break;
708181254a7Smrg     case SEEK_END:
709181254a7Smrg       offset += s->file_length;
710181254a7Smrg       break;
711181254a7Smrg     default:
712181254a7Smrg       return -1;
713181254a7Smrg     }
714181254a7Smrg   if (offset < 0)
715181254a7Smrg     {
716181254a7Smrg       errno = EINVAL;
717181254a7Smrg       return -1;
718181254a7Smrg     }
719181254a7Smrg   s->logical_offset = offset;
720181254a7Smrg   return offset;
721181254a7Smrg }
722181254a7Smrg 
723181254a7Smrg static gfc_offset
buf_tell(unix_stream * s)724181254a7Smrg buf_tell (unix_stream *s)
725181254a7Smrg {
726181254a7Smrg   return buf_seek (s, 0, SEEK_CUR);
727181254a7Smrg }
728181254a7Smrg 
729181254a7Smrg static gfc_offset
buf_size(unix_stream * s)730181254a7Smrg buf_size (unix_stream *s)
731181254a7Smrg {
732181254a7Smrg   return s->file_length;
733181254a7Smrg }
734181254a7Smrg 
735181254a7Smrg static int
buf_truncate(unix_stream * s,gfc_offset length)736181254a7Smrg buf_truncate (unix_stream *s, gfc_offset length)
737181254a7Smrg {
738181254a7Smrg   int r;
739181254a7Smrg 
740181254a7Smrg   if (buf_flush (s) != 0)
741181254a7Smrg     return -1;
742181254a7Smrg   r = raw_truncate (s, length);
743181254a7Smrg   if (r == 0)
744181254a7Smrg     s->file_length = length;
745181254a7Smrg   return r;
746181254a7Smrg }
747181254a7Smrg 
748181254a7Smrg static int
buf_close(unix_stream * s)749181254a7Smrg buf_close (unix_stream *s)
750181254a7Smrg {
751181254a7Smrg   if (buf_flush (s) != 0)
752181254a7Smrg     return -1;
753181254a7Smrg   free (s->buffer);
754181254a7Smrg   return raw_close (s);
755181254a7Smrg }
756181254a7Smrg 
757181254a7Smrg static const struct stream_vtable buf_vtable = {
758181254a7Smrg   .read = (void *) buf_read,
759181254a7Smrg   .write = (void *) buf_write,
760181254a7Smrg   .seek = (void *) buf_seek,
761181254a7Smrg   .tell = (void *) buf_tell,
762181254a7Smrg   .size = (void *) buf_size,
763181254a7Smrg   .trunc = (void *) buf_truncate,
764181254a7Smrg   .close = (void *) buf_close,
765181254a7Smrg   .flush = (void *) buf_flush,
766181254a7Smrg   .markeor = (void *) buf_markeor
767181254a7Smrg };
768181254a7Smrg 
769181254a7Smrg static int
buf_init(unix_stream * s,bool unformatted)770181254a7Smrg buf_init (unix_stream *s, bool unformatted)
771181254a7Smrg {
772181254a7Smrg   s->st.vptr = &buf_vtable;
773181254a7Smrg 
774181254a7Smrg   /* Try to guess a good value for the buffer size.  For formatted
775181254a7Smrg      I/O, we use so many CPU cycles converting the data that there is
776181254a7Smrg      more sense in converving memory and especially cache.  For
777181254a7Smrg      unformatted, a bigger block can have a large impact in some
778181254a7Smrg      environments.  */
779181254a7Smrg 
780181254a7Smrg   if (unformatted)
781181254a7Smrg     {
782181254a7Smrg       if (options.unformatted_buffer_size > 0)
783181254a7Smrg 	s->buffer_size = options.unformatted_buffer_size;
784181254a7Smrg       else
785181254a7Smrg 	s->buffer_size = UNFORMATTED_BUFFER_SIZE_DEFAULT;
786181254a7Smrg     }
787181254a7Smrg   else
788181254a7Smrg     {
789181254a7Smrg       if (options.formatted_buffer_size > 0)
790181254a7Smrg 	s->buffer_size = options.formatted_buffer_size;
791181254a7Smrg       else
792181254a7Smrg 	s->buffer_size = FORMATTED_BUFFER_SIZE_DEFAULT;
793181254a7Smrg     }
794181254a7Smrg 
795181254a7Smrg   s->buffer = xmalloc (s->buffer_size);
796181254a7Smrg   return 0;
797181254a7Smrg }
798181254a7Smrg 
799181254a7Smrg 
800181254a7Smrg /*********************************************************************
801181254a7Smrg   memory stream functions - These are used for internal files
802181254a7Smrg 
803181254a7Smrg   The idea here is that a single stream structure is created and all
804181254a7Smrg   requests must be satisfied from it.  The location and size of the
805181254a7Smrg   buffer is the character variable supplied to the READ or WRITE
806181254a7Smrg   statement.
807181254a7Smrg 
808181254a7Smrg *********************************************************************/
809181254a7Smrg 
810181254a7Smrg char *
mem_alloc_r(stream * strm,size_t * len)811181254a7Smrg mem_alloc_r (stream *strm, size_t *len)
812181254a7Smrg {
813181254a7Smrg   unix_stream *s = (unix_stream *) strm;
814181254a7Smrg   gfc_offset n;
815181254a7Smrg   gfc_offset where = s->logical_offset;
816181254a7Smrg 
817181254a7Smrg   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
818181254a7Smrg     return NULL;
819181254a7Smrg 
820181254a7Smrg   n = s->buffer_offset + s->active - where;
821181254a7Smrg   if ((gfc_offset) *len > n)
822181254a7Smrg     *len = n;
823181254a7Smrg 
824181254a7Smrg   s->logical_offset = where + *len;
825181254a7Smrg 
826181254a7Smrg   return s->buffer + (where - s->buffer_offset);
827181254a7Smrg }
828181254a7Smrg 
829181254a7Smrg 
830181254a7Smrg char *
mem_alloc_r4(stream * strm,size_t * len)831181254a7Smrg mem_alloc_r4 (stream *strm, size_t *len)
832181254a7Smrg {
833181254a7Smrg   unix_stream *s = (unix_stream *) strm;
834181254a7Smrg   gfc_offset n;
835181254a7Smrg   gfc_offset where = s->logical_offset;
836181254a7Smrg 
837181254a7Smrg   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
838181254a7Smrg     return NULL;
839181254a7Smrg 
840181254a7Smrg   n = s->buffer_offset + s->active - where;
841181254a7Smrg   if ((gfc_offset) *len > n)
842181254a7Smrg     *len = n;
843181254a7Smrg 
844181254a7Smrg   s->logical_offset = where + *len;
845181254a7Smrg 
846181254a7Smrg   return s->buffer + (where - s->buffer_offset) * 4;
847181254a7Smrg }
848181254a7Smrg 
849181254a7Smrg 
850181254a7Smrg char *
mem_alloc_w(stream * strm,size_t * len)851181254a7Smrg mem_alloc_w (stream *strm, size_t *len)
852181254a7Smrg {
853181254a7Smrg   unix_stream *s = (unix_stream *)strm;
854181254a7Smrg   gfc_offset m;
855181254a7Smrg   gfc_offset where = s->logical_offset;
856181254a7Smrg 
857181254a7Smrg   m = where + *len;
858181254a7Smrg 
859181254a7Smrg   if (where < s->buffer_offset)
860181254a7Smrg     return NULL;
861181254a7Smrg 
862181254a7Smrg   if (m > s->file_length)
863181254a7Smrg     return NULL;
864181254a7Smrg 
865181254a7Smrg   s->logical_offset = m;
866181254a7Smrg 
867181254a7Smrg   return s->buffer + (where - s->buffer_offset);
868181254a7Smrg }
869181254a7Smrg 
870181254a7Smrg 
871181254a7Smrg gfc_char4_t *
mem_alloc_w4(stream * strm,size_t * len)872181254a7Smrg mem_alloc_w4 (stream *strm, size_t *len)
873181254a7Smrg {
874181254a7Smrg   unix_stream *s = (unix_stream *)strm;
875181254a7Smrg   gfc_offset m;
876181254a7Smrg   gfc_offset where = s->logical_offset;
877181254a7Smrg   gfc_char4_t *result = (gfc_char4_t *) s->buffer;
878181254a7Smrg 
879181254a7Smrg   m = where + *len;
880181254a7Smrg 
881181254a7Smrg   if (where < s->buffer_offset)
882181254a7Smrg     return NULL;
883181254a7Smrg 
884181254a7Smrg   if (m > s->file_length)
885181254a7Smrg     return NULL;
886181254a7Smrg 
887181254a7Smrg   s->logical_offset = m;
888181254a7Smrg   return &result[where - s->buffer_offset];
889181254a7Smrg }
890181254a7Smrg 
891181254a7Smrg 
892181254a7Smrg /* Stream read function for character(kind=1) internal units.  */
893181254a7Smrg 
894181254a7Smrg static ssize_t
mem_read(stream * s,void * buf,ssize_t nbytes)895181254a7Smrg mem_read (stream *s, void *buf, ssize_t nbytes)
896181254a7Smrg {
897181254a7Smrg   void *p;
898181254a7Smrg   size_t nb = nbytes;
899181254a7Smrg 
900181254a7Smrg   p = mem_alloc_r (s, &nb);
901181254a7Smrg   if (p)
902181254a7Smrg     {
903181254a7Smrg       memcpy (buf, p, nb);
904181254a7Smrg       return (ssize_t) nb;
905181254a7Smrg     }
906181254a7Smrg   else
907181254a7Smrg     return 0;
908181254a7Smrg }
909181254a7Smrg 
910181254a7Smrg 
911181254a7Smrg /* Stream read function for chracter(kind=4) internal units.  */
912181254a7Smrg 
913181254a7Smrg static ssize_t
mem_read4(stream * s,void * buf,ssize_t nbytes)914181254a7Smrg mem_read4 (stream *s, void *buf, ssize_t nbytes)
915181254a7Smrg {
916181254a7Smrg   void *p;
917181254a7Smrg   size_t nb = nbytes;
918181254a7Smrg 
919181254a7Smrg   p = mem_alloc_r4 (s, &nb);
920181254a7Smrg   if (p)
921181254a7Smrg     {
922181254a7Smrg       memcpy (buf, p, nb * 4);
923181254a7Smrg       return (ssize_t) nb;
924181254a7Smrg     }
925181254a7Smrg   else
926181254a7Smrg     return 0;
927181254a7Smrg }
928181254a7Smrg 
929181254a7Smrg 
930181254a7Smrg /* Stream write function for character(kind=1) internal units.  */
931181254a7Smrg 
932181254a7Smrg static ssize_t
mem_write(stream * s,const void * buf,ssize_t nbytes)933181254a7Smrg mem_write (stream *s, const void *buf, ssize_t nbytes)
934181254a7Smrg {
935181254a7Smrg   void *p;
936181254a7Smrg   size_t nb = nbytes;
937181254a7Smrg 
938181254a7Smrg   p = mem_alloc_w (s, &nb);
939181254a7Smrg   if (p)
940181254a7Smrg     {
941181254a7Smrg       memcpy (p, buf, nb);
942181254a7Smrg       return (ssize_t) nb;
943181254a7Smrg     }
944181254a7Smrg   else
945181254a7Smrg     return 0;
946181254a7Smrg }
947181254a7Smrg 
948181254a7Smrg 
949181254a7Smrg /* Stream write function for character(kind=4) internal units.  */
950181254a7Smrg 
951181254a7Smrg static ssize_t
mem_write4(stream * s,const void * buf,ssize_t nwords)952181254a7Smrg mem_write4 (stream *s, const void *buf, ssize_t nwords)
953181254a7Smrg {
954181254a7Smrg   gfc_char4_t *p;
955181254a7Smrg   size_t nw = nwords;
956181254a7Smrg 
957181254a7Smrg   p = mem_alloc_w4 (s, &nw);
958181254a7Smrg   if (p)
959181254a7Smrg     {
960181254a7Smrg       while (nw--)
961181254a7Smrg 	*p++ = (gfc_char4_t) *((char *) buf);
962181254a7Smrg       return nwords;
963181254a7Smrg     }
964181254a7Smrg   else
965181254a7Smrg     return 0;
966181254a7Smrg }
967181254a7Smrg 
968181254a7Smrg 
969181254a7Smrg static gfc_offset
mem_seek(stream * strm,gfc_offset offset,int whence)970181254a7Smrg mem_seek (stream *strm, gfc_offset offset, int whence)
971181254a7Smrg {
972181254a7Smrg   unix_stream *s = (unix_stream *)strm;
973181254a7Smrg   switch (whence)
974181254a7Smrg     {
975181254a7Smrg     case SEEK_SET:
976181254a7Smrg       break;
977181254a7Smrg     case SEEK_CUR:
978181254a7Smrg       offset += s->logical_offset;
979181254a7Smrg       break;
980181254a7Smrg     case SEEK_END:
981181254a7Smrg       offset += s->file_length;
982181254a7Smrg       break;
983181254a7Smrg     default:
984181254a7Smrg       return -1;
985181254a7Smrg     }
986181254a7Smrg 
987181254a7Smrg   /* Note that for internal array I/O it's actually possible to have a
988181254a7Smrg      negative offset, so don't check for that.  */
989181254a7Smrg   if (offset > s->file_length)
990181254a7Smrg     {
991181254a7Smrg       errno = EINVAL;
992181254a7Smrg       return -1;
993181254a7Smrg     }
994181254a7Smrg 
995181254a7Smrg   s->logical_offset = offset;
996181254a7Smrg 
997181254a7Smrg   /* Returning < 0 is the error indicator for sseek(), so return 0 if
998181254a7Smrg      offset is negative.  Thus if the return value is 0, the caller
999181254a7Smrg      has to use stell() to get the real value of logical_offset.  */
1000181254a7Smrg   if (offset >= 0)
1001181254a7Smrg     return offset;
1002181254a7Smrg   return 0;
1003181254a7Smrg }
1004181254a7Smrg 
1005181254a7Smrg 
1006181254a7Smrg static gfc_offset
mem_tell(stream * s)1007181254a7Smrg mem_tell (stream *s)
1008181254a7Smrg {
1009181254a7Smrg   return ((unix_stream *)s)->logical_offset;
1010181254a7Smrg }
1011181254a7Smrg 
1012181254a7Smrg 
1013181254a7Smrg static int
mem_truncate(unix_stream * s,gfc_offset length)1014181254a7Smrg mem_truncate (unix_stream *s __attribute__ ((unused)),
1015181254a7Smrg 	      gfc_offset length __attribute__ ((unused)))
1016181254a7Smrg {
1017181254a7Smrg   return 0;
1018181254a7Smrg }
1019181254a7Smrg 
1020181254a7Smrg 
1021181254a7Smrg static int
mem_flush(unix_stream * s)1022181254a7Smrg mem_flush (unix_stream *s __attribute__ ((unused)))
1023181254a7Smrg {
1024181254a7Smrg   return 0;
1025181254a7Smrg }
1026181254a7Smrg 
1027181254a7Smrg 
1028181254a7Smrg static int
mem_close(unix_stream * s)1029181254a7Smrg mem_close (unix_stream *s)
1030181254a7Smrg {
1031181254a7Smrg   if (s)
1032181254a7Smrg     free (s);
1033181254a7Smrg   return 0;
1034181254a7Smrg }
1035181254a7Smrg 
1036181254a7Smrg static const struct stream_vtable mem_vtable = {
1037181254a7Smrg   .read = (void *) mem_read,
1038181254a7Smrg   .write = (void *) mem_write,
1039181254a7Smrg   .seek = (void *) mem_seek,
1040181254a7Smrg   .tell = (void *) mem_tell,
1041181254a7Smrg   /* buf_size is not a typo, we just reuse an identical
1042181254a7Smrg      implementation.  */
1043181254a7Smrg   .size = (void *) buf_size,
1044181254a7Smrg   .trunc = (void *) mem_truncate,
1045181254a7Smrg   .close = (void *) mem_close,
1046181254a7Smrg   .flush = (void *) mem_flush,
1047181254a7Smrg   .markeor = (void *) raw_markeor
1048181254a7Smrg };
1049181254a7Smrg 
1050181254a7Smrg static const struct stream_vtable mem4_vtable = {
1051181254a7Smrg   .read = (void *) mem_read4,
1052181254a7Smrg   .write = (void *) mem_write4,
1053181254a7Smrg   .seek = (void *) mem_seek,
1054181254a7Smrg   .tell = (void *) mem_tell,
1055181254a7Smrg   /* buf_size is not a typo, we just reuse an identical
1056181254a7Smrg      implementation.  */
1057181254a7Smrg   .size = (void *) buf_size,
1058181254a7Smrg   .trunc = (void *) mem_truncate,
1059181254a7Smrg   .close = (void *) mem_close,
1060181254a7Smrg   .flush = (void *) mem_flush,
1061181254a7Smrg   .markeor = (void *) raw_markeor
1062181254a7Smrg };
1063181254a7Smrg 
1064181254a7Smrg /*********************************************************************
1065181254a7Smrg   Public functions -- A reimplementation of this module needs to
1066181254a7Smrg   define functional equivalents of the following.
1067181254a7Smrg *********************************************************************/
1068181254a7Smrg 
1069181254a7Smrg /* open_internal()-- Returns a stream structure from a character(kind=1)
1070181254a7Smrg    internal file */
1071181254a7Smrg 
1072181254a7Smrg stream *
open_internal(char * base,size_t length,gfc_offset offset)1073181254a7Smrg open_internal (char *base, size_t length, gfc_offset offset)
1074181254a7Smrg {
1075181254a7Smrg   unix_stream *s;
1076181254a7Smrg 
1077181254a7Smrg   s = xcalloc (1, sizeof (unix_stream));
1078181254a7Smrg 
1079181254a7Smrg   s->buffer = base;
1080181254a7Smrg   s->buffer_offset = offset;
1081181254a7Smrg 
1082181254a7Smrg   s->active = s->file_length = length;
1083181254a7Smrg 
1084181254a7Smrg   s->st.vptr = &mem_vtable;
1085181254a7Smrg 
1086181254a7Smrg   return (stream *) s;
1087181254a7Smrg }
1088181254a7Smrg 
1089181254a7Smrg /* open_internal4()-- Returns a stream structure from a character(kind=4)
1090181254a7Smrg    internal file */
1091181254a7Smrg 
1092181254a7Smrg stream *
open_internal4(char * base,size_t length,gfc_offset offset)1093181254a7Smrg open_internal4 (char *base, size_t length, gfc_offset offset)
1094181254a7Smrg {
1095181254a7Smrg   unix_stream *s;
1096181254a7Smrg 
1097181254a7Smrg   s = xcalloc (1, sizeof (unix_stream));
1098181254a7Smrg 
1099181254a7Smrg   s->buffer = base;
1100181254a7Smrg   s->buffer_offset = offset;
1101181254a7Smrg 
1102181254a7Smrg   s->active = s->file_length = length * sizeof (gfc_char4_t);
1103181254a7Smrg 
1104181254a7Smrg   s->st.vptr = &mem4_vtable;
1105181254a7Smrg 
1106181254a7Smrg   return (stream *)s;
1107181254a7Smrg }
1108181254a7Smrg 
1109181254a7Smrg 
1110181254a7Smrg /* fd_to_stream()-- Given an open file descriptor, build a stream
1111181254a7Smrg    around it. */
1112181254a7Smrg 
1113181254a7Smrg static stream *
fd_to_stream(int fd,bool unformatted)1114181254a7Smrg fd_to_stream (int fd, bool unformatted)
1115181254a7Smrg {
1116181254a7Smrg   struct stat statbuf;
1117181254a7Smrg   unix_stream *s;
1118181254a7Smrg 
1119181254a7Smrg   s = xcalloc (1, sizeof (unix_stream));
1120181254a7Smrg 
1121181254a7Smrg   s->fd = fd;
1122181254a7Smrg 
1123181254a7Smrg   /* Get the current length of the file. */
1124181254a7Smrg 
1125181254a7Smrg   if (TEMP_FAILURE_RETRY (fstat (fd, &statbuf)) == -1)
1126181254a7Smrg     {
1127181254a7Smrg       s->st_dev = s->st_ino = -1;
1128181254a7Smrg       s->file_length = 0;
1129181254a7Smrg       if (errno == EBADF)
1130181254a7Smrg 	s->fd = -1;
1131181254a7Smrg       raw_init (s);
1132181254a7Smrg       return (stream *) s;
1133181254a7Smrg     }
1134181254a7Smrg 
1135181254a7Smrg   s->st_dev = statbuf.st_dev;
1136181254a7Smrg   s->st_ino = statbuf.st_ino;
1137181254a7Smrg   s->file_length = statbuf.st_size;
1138181254a7Smrg 
1139181254a7Smrg   /* Only use buffered IO for regular files.  */
1140181254a7Smrg   if (S_ISREG (statbuf.st_mode)
1141181254a7Smrg       && !options.all_unbuffered
1142181254a7Smrg       && !(options.unbuffered_preconnected &&
1143181254a7Smrg 	   (s->fd == STDIN_FILENO
1144181254a7Smrg 	    || s->fd == STDOUT_FILENO
1145181254a7Smrg 	    || s->fd == STDERR_FILENO)))
1146181254a7Smrg     buf_init (s, unformatted);
1147181254a7Smrg   else
1148181254a7Smrg     {
1149181254a7Smrg       if (unformatted)
1150181254a7Smrg 	{
1151181254a7Smrg 	  s->unbuffered = true;
1152181254a7Smrg 	  buf_init (s, unformatted);
1153181254a7Smrg 	}
1154181254a7Smrg       else
1155181254a7Smrg 	raw_init (s);
1156181254a7Smrg     }
1157181254a7Smrg 
1158181254a7Smrg   return (stream *) s;
1159181254a7Smrg }
1160181254a7Smrg 
1161181254a7Smrg 
1162181254a7Smrg /* Given the Fortran unit number, convert it to a C file descriptor.  */
1163181254a7Smrg 
1164181254a7Smrg int
unit_to_fd(int unit)1165181254a7Smrg unit_to_fd (int unit)
1166181254a7Smrg {
1167181254a7Smrg   gfc_unit *us;
1168181254a7Smrg   int fd;
1169181254a7Smrg 
1170181254a7Smrg   us = find_unit (unit);
1171181254a7Smrg   if (us == NULL)
1172181254a7Smrg     return -1;
1173181254a7Smrg 
1174181254a7Smrg   fd = ((unix_stream *) us->s)->fd;
1175181254a7Smrg   unlock_unit (us);
1176181254a7Smrg   return fd;
1177181254a7Smrg }
1178181254a7Smrg 
1179181254a7Smrg 
1180181254a7Smrg /* Set the close-on-exec flag for an existing fd, if the system
1181181254a7Smrg    supports such.  */
1182181254a7Smrg 
1183181254a7Smrg static void __attribute__ ((unused))
set_close_on_exec(int fd)1184181254a7Smrg set_close_on_exec (int fd __attribute__ ((unused)))
1185181254a7Smrg {
1186181254a7Smrg   /* Mingw does not define F_SETFD.  */
1187181254a7Smrg #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1188181254a7Smrg   if (fd >= 0)
1189181254a7Smrg     fcntl(fd, F_SETFD, FD_CLOEXEC);
1190181254a7Smrg #endif
1191181254a7Smrg }
1192181254a7Smrg 
1193181254a7Smrg 
1194181254a7Smrg /* Helper function for tempfile(). Tries to open a temporary file in
1195181254a7Smrg    the directory specified by tempdir. If successful, the file name is
1196181254a7Smrg    stored in fname and the descriptor returned. Returns -1 on
1197181254a7Smrg    failure.  */
1198181254a7Smrg 
1199181254a7Smrg static int
tempfile_open(const char * tempdir,char ** fname)1200181254a7Smrg tempfile_open (const char *tempdir, char **fname)
1201181254a7Smrg {
1202181254a7Smrg   int fd;
1203181254a7Smrg   const char *slash = "/";
1204181254a7Smrg #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1205181254a7Smrg   mode_t mode_mask;
1206181254a7Smrg #endif
1207181254a7Smrg 
1208181254a7Smrg   if (!tempdir)
1209181254a7Smrg     return -1;
1210181254a7Smrg 
1211181254a7Smrg   /* Check for the special case that tempdir ends with a slash or
1212181254a7Smrg      backslash.  */
1213181254a7Smrg   size_t tempdirlen = strlen (tempdir);
1214181254a7Smrg   if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1215181254a7Smrg #ifdef __MINGW32__
1216181254a7Smrg       || tempdir[tempdirlen - 1] == '\\'
1217181254a7Smrg #endif
1218181254a7Smrg      )
1219181254a7Smrg     slash = "";
1220181254a7Smrg 
1221181254a7Smrg   /* Take care that the template is longer in the mktemp() branch.  */
1222181254a7Smrg   char *template = xmalloc (tempdirlen + 23);
1223181254a7Smrg 
1224181254a7Smrg #ifdef HAVE_MKSTEMP
1225181254a7Smrg   snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1226181254a7Smrg 	    tempdir, slash);
1227181254a7Smrg 
1228181254a7Smrg #ifdef HAVE_UMASK
1229181254a7Smrg   /* Temporarily set the umask such that the file has 0600 permissions.  */
1230181254a7Smrg   mode_mask = umask (S_IXUSR | S_IRWXG | S_IRWXO);
1231181254a7Smrg #endif
1232181254a7Smrg 
1233181254a7Smrg #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1234181254a7Smrg   TEMP_FAILURE_RETRY (fd = mkostemp (template, O_CLOEXEC));
1235181254a7Smrg #else
1236181254a7Smrg   TEMP_FAILURE_RETRY (fd = mkstemp (template));
1237181254a7Smrg   set_close_on_exec (fd);
1238181254a7Smrg #endif
1239181254a7Smrg 
1240181254a7Smrg #ifdef HAVE_UMASK
1241181254a7Smrg   (void) umask (mode_mask);
1242181254a7Smrg #endif
1243181254a7Smrg 
1244181254a7Smrg #else /* HAVE_MKSTEMP */
1245181254a7Smrg   fd = -1;
1246181254a7Smrg   int count = 0;
1247181254a7Smrg   size_t slashlen = strlen (slash);
1248181254a7Smrg   int flags = O_RDWR | O_CREAT | O_EXCL;
1249181254a7Smrg #if defined(HAVE_CRLF) && defined(O_BINARY)
1250181254a7Smrg   flags |= O_BINARY;
1251181254a7Smrg #endif
1252181254a7Smrg #ifdef O_CLOEXEC
1253181254a7Smrg   flags |= O_CLOEXEC;
1254181254a7Smrg #endif
1255181254a7Smrg   do
1256181254a7Smrg     {
1257181254a7Smrg       snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1258181254a7Smrg 		tempdir, slash);
1259181254a7Smrg       if (count > 0)
1260181254a7Smrg 	{
1261181254a7Smrg 	  int c = count;
1262181254a7Smrg 	  template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1263181254a7Smrg 	  c /= 26;
1264181254a7Smrg 	  template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1265181254a7Smrg 	  c /= 26;
1266181254a7Smrg 	  template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1267181254a7Smrg 	  if (c >= 26)
1268181254a7Smrg 	    break;
1269181254a7Smrg 	}
1270181254a7Smrg 
1271181254a7Smrg       if (!mktemp (template))
1272181254a7Smrg       {
1273181254a7Smrg 	errno = EEXIST;
1274181254a7Smrg 	count++;
1275181254a7Smrg 	continue;
1276181254a7Smrg       }
1277181254a7Smrg 
1278181254a7Smrg       TEMP_FAILURE_RETRY (fd = open (template, flags, S_IRUSR | S_IWUSR));
1279181254a7Smrg     }
1280181254a7Smrg   while (fd == -1 && errno == EEXIST);
1281181254a7Smrg #ifndef O_CLOEXEC
1282181254a7Smrg   set_close_on_exec (fd);
1283181254a7Smrg #endif
1284181254a7Smrg #endif /* HAVE_MKSTEMP */
1285181254a7Smrg 
1286181254a7Smrg   *fname = template;
1287181254a7Smrg   return fd;
1288181254a7Smrg }
1289181254a7Smrg 
1290181254a7Smrg 
1291181254a7Smrg /* tempfile()-- Generate a temporary filename for a scratch file and
1292181254a7Smrg    open it.  mkstemp() opens the file for reading and writing, but the
1293181254a7Smrg    library mode prevents anything that is not allowed.  The descriptor
1294181254a7Smrg    is returned, which is -1 on error.  The template is pointed to by
1295181254a7Smrg    opp->file, which is copied into the unit structure
1296181254a7Smrg    and freed later. */
1297181254a7Smrg 
1298181254a7Smrg static int
tempfile(st_parameter_open * opp)1299181254a7Smrg tempfile (st_parameter_open *opp)
1300181254a7Smrg {
1301181254a7Smrg   const char *tempdir;
1302181254a7Smrg   char *fname;
1303181254a7Smrg   int fd = -1;
1304181254a7Smrg 
1305181254a7Smrg   tempdir = secure_getenv ("TMPDIR");
1306181254a7Smrg   fd = tempfile_open (tempdir, &fname);
1307181254a7Smrg #ifdef __MINGW32__
1308181254a7Smrg   if (fd == -1)
1309181254a7Smrg     {
1310181254a7Smrg       char buffer[MAX_PATH + 1];
1311181254a7Smrg       DWORD ret;
1312181254a7Smrg       ret = GetTempPath (MAX_PATH, buffer);
1313181254a7Smrg       /* If we are not able to get a temp-directory, we use
1314181254a7Smrg 	 current directory.  */
1315181254a7Smrg       if (ret > MAX_PATH || !ret)
1316181254a7Smrg         buffer[0] = 0;
1317181254a7Smrg       else
1318181254a7Smrg         buffer[ret] = 0;
1319181254a7Smrg       tempdir = strdup (buffer);
1320181254a7Smrg       fd = tempfile_open (tempdir, &fname);
1321181254a7Smrg     }
1322181254a7Smrg #elif defined(__CYGWIN__)
1323181254a7Smrg   if (fd == -1)
1324181254a7Smrg     {
1325181254a7Smrg       tempdir = secure_getenv ("TMP");
1326181254a7Smrg       fd = tempfile_open (tempdir, &fname);
1327181254a7Smrg     }
1328181254a7Smrg   if (fd == -1)
1329181254a7Smrg     {
1330181254a7Smrg       tempdir = secure_getenv ("TEMP");
1331181254a7Smrg       fd = tempfile_open (tempdir, &fname);
1332181254a7Smrg     }
1333181254a7Smrg #endif
1334181254a7Smrg   if (fd == -1)
1335181254a7Smrg     fd = tempfile_open (P_tmpdir, &fname);
1336181254a7Smrg 
1337181254a7Smrg   opp->file = fname;
1338181254a7Smrg   opp->file_len = strlen (fname);	/* Don't include trailing nul */
1339181254a7Smrg 
1340181254a7Smrg   return fd;
1341181254a7Smrg }
1342181254a7Smrg 
1343181254a7Smrg 
1344181254a7Smrg /* regular_file2()-- Open a regular file.
1345181254a7Smrg    Change flags->action if it is ACTION_UNSPECIFIED on entry,
1346181254a7Smrg    unless an error occurs.
1347181254a7Smrg    Returns the descriptor, which is less than zero on error. */
1348181254a7Smrg 
1349181254a7Smrg static int
regular_file2(const char * path,st_parameter_open * opp,unit_flags * flags)1350181254a7Smrg regular_file2 (const char *path, st_parameter_open *opp, unit_flags *flags)
1351181254a7Smrg {
1352181254a7Smrg   int mode;
1353181254a7Smrg   int rwflag;
1354181254a7Smrg   int crflag, crflag2;
1355181254a7Smrg   int fd;
1356181254a7Smrg 
1357181254a7Smrg #ifdef __CYGWIN__
1358181254a7Smrg   if (opp->file_len == 7)
1359181254a7Smrg     {
1360181254a7Smrg       if (strncmp (path, "CONOUT$", 7) == 0
1361181254a7Smrg 	  || strncmp (path, "CONERR$", 7) == 0)
1362181254a7Smrg 	{
1363181254a7Smrg 	  fd = open ("/dev/conout", O_WRONLY);
1364181254a7Smrg 	  flags->action = ACTION_WRITE;
1365181254a7Smrg 	  return fd;
1366181254a7Smrg 	}
1367181254a7Smrg     }
1368181254a7Smrg 
1369181254a7Smrg   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1370181254a7Smrg     {
1371181254a7Smrg       fd = open ("/dev/conin", O_RDONLY);
1372181254a7Smrg       flags->action = ACTION_READ;
1373181254a7Smrg       return fd;
1374181254a7Smrg     }
1375181254a7Smrg #endif
1376181254a7Smrg 
1377181254a7Smrg 
1378181254a7Smrg #ifdef __MINGW32__
1379181254a7Smrg   if (opp->file_len == 7)
1380181254a7Smrg     {
1381181254a7Smrg       if (strncmp (path, "CONOUT$", 7) == 0
1382181254a7Smrg 	  || strncmp (path, "CONERR$", 7) == 0)
1383181254a7Smrg 	{
1384181254a7Smrg 	  fd = open ("CONOUT$", O_WRONLY);
1385181254a7Smrg 	  flags->action = ACTION_WRITE;
1386181254a7Smrg 	  return fd;
1387181254a7Smrg 	}
1388181254a7Smrg     }
1389181254a7Smrg 
1390181254a7Smrg   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1391181254a7Smrg     {
1392181254a7Smrg       fd = open ("CONIN$", O_RDONLY);
1393181254a7Smrg       flags->action = ACTION_READ;
1394181254a7Smrg       return fd;
1395181254a7Smrg     }
1396181254a7Smrg #endif
1397181254a7Smrg 
1398181254a7Smrg   switch (flags->action)
1399181254a7Smrg     {
1400181254a7Smrg     case ACTION_READ:
1401181254a7Smrg       rwflag = O_RDONLY;
1402181254a7Smrg       break;
1403181254a7Smrg 
1404181254a7Smrg     case ACTION_WRITE:
1405181254a7Smrg       rwflag = O_WRONLY;
1406181254a7Smrg       break;
1407181254a7Smrg 
1408181254a7Smrg     case ACTION_READWRITE:
1409181254a7Smrg     case ACTION_UNSPECIFIED:
1410181254a7Smrg       rwflag = O_RDWR;
1411181254a7Smrg       break;
1412181254a7Smrg 
1413181254a7Smrg     default:
1414181254a7Smrg       internal_error (&opp->common, "regular_file(): Bad action");
1415181254a7Smrg     }
1416181254a7Smrg 
1417181254a7Smrg   switch (flags->status)
1418181254a7Smrg     {
1419181254a7Smrg     case STATUS_NEW:
1420181254a7Smrg       crflag = O_CREAT | O_EXCL;
1421181254a7Smrg       break;
1422181254a7Smrg 
1423181254a7Smrg     case STATUS_OLD:		/* open will fail if the file does not exist*/
1424181254a7Smrg       crflag = 0;
1425181254a7Smrg       break;
1426181254a7Smrg 
1427181254a7Smrg     case STATUS_UNKNOWN:
1428181254a7Smrg       if (rwflag == O_RDONLY)
1429181254a7Smrg 	crflag = 0;
1430181254a7Smrg       else
1431181254a7Smrg 	crflag = O_CREAT;
1432181254a7Smrg       break;
1433181254a7Smrg 
1434181254a7Smrg     case STATUS_REPLACE:
1435181254a7Smrg       crflag = O_CREAT | O_TRUNC;
1436181254a7Smrg       break;
1437181254a7Smrg 
1438181254a7Smrg     default:
1439181254a7Smrg       /* Note: STATUS_SCRATCH is handled by tempfile () and should
1440181254a7Smrg 	 never be seen here.  */
1441181254a7Smrg       internal_error (&opp->common, "regular_file(): Bad status");
1442181254a7Smrg     }
1443181254a7Smrg 
1444181254a7Smrg   /* rwflag |= O_LARGEFILE; */
1445181254a7Smrg 
1446181254a7Smrg #if defined(HAVE_CRLF) && defined(O_BINARY)
1447181254a7Smrg   crflag |= O_BINARY;
1448181254a7Smrg #endif
1449181254a7Smrg 
1450181254a7Smrg #ifdef O_CLOEXEC
1451181254a7Smrg   crflag |= O_CLOEXEC;
1452181254a7Smrg #endif
1453181254a7Smrg 
1454181254a7Smrg   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1455181254a7Smrg   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1456181254a7Smrg   if (flags->action != ACTION_UNSPECIFIED)
1457181254a7Smrg     return fd;
1458181254a7Smrg 
1459181254a7Smrg   if (fd >= 0)
1460181254a7Smrg     {
1461181254a7Smrg       flags->action = ACTION_READWRITE;
1462181254a7Smrg       return fd;
1463181254a7Smrg     }
1464181254a7Smrg   if (errno != EACCES && errno != EPERM && errno != EROFS)
1465181254a7Smrg      return fd;
1466181254a7Smrg 
1467181254a7Smrg   /* retry for read-only access */
1468181254a7Smrg   rwflag = O_RDONLY;
1469181254a7Smrg   if (flags->status == STATUS_UNKNOWN)
1470181254a7Smrg     crflag2 = crflag & ~(O_CREAT);
1471181254a7Smrg   else
1472181254a7Smrg     crflag2 = crflag;
1473181254a7Smrg   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag2, mode));
1474181254a7Smrg   if (fd >=0)
1475181254a7Smrg     {
1476181254a7Smrg       flags->action = ACTION_READ;
1477181254a7Smrg       return fd;		/* success */
1478181254a7Smrg     }
1479181254a7Smrg 
1480181254a7Smrg   if (errno != EACCES && errno != EPERM && errno != ENOENT)
1481181254a7Smrg     return fd;			/* failure */
1482181254a7Smrg 
1483181254a7Smrg   /* retry for write-only access */
1484181254a7Smrg   rwflag = O_WRONLY;
1485181254a7Smrg   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1486181254a7Smrg   if (fd >=0)
1487181254a7Smrg     {
1488181254a7Smrg       flags->action = ACTION_WRITE;
1489181254a7Smrg       return fd;		/* success */
1490181254a7Smrg     }
1491181254a7Smrg   return fd;			/* failure */
1492181254a7Smrg }
1493181254a7Smrg 
1494181254a7Smrg 
1495181254a7Smrg /* Lock the file, if necessary, based on SHARE flags.  */
1496181254a7Smrg 
1497181254a7Smrg #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1498181254a7Smrg static int
open_share(st_parameter_open * opp,int fd,unit_flags * flags)1499181254a7Smrg open_share (st_parameter_open *opp, int fd, unit_flags *flags)
1500181254a7Smrg {
1501181254a7Smrg   int r = 0;
1502181254a7Smrg   struct flock f;
1503181254a7Smrg   if (fd == STDOUT_FILENO || fd == STDERR_FILENO || fd == STDIN_FILENO)
1504181254a7Smrg     return 0;
1505181254a7Smrg 
1506181254a7Smrg   f.l_start = 0;
1507181254a7Smrg   f.l_len = 0;
1508181254a7Smrg   f.l_whence = SEEK_SET;
1509181254a7Smrg 
1510181254a7Smrg   switch (flags->share)
1511181254a7Smrg   {
1512181254a7Smrg     case SHARE_DENYNONE:
1513181254a7Smrg       f.l_type = F_RDLCK;
1514181254a7Smrg       r = fcntl (fd, F_SETLK, &f);
1515181254a7Smrg       break;
1516181254a7Smrg     case SHARE_DENYRW:
1517181254a7Smrg       /* Must be writable to hold write lock.  */
1518181254a7Smrg       if (flags->action == ACTION_READ)
1519181254a7Smrg 	{
1520181254a7Smrg 	  generate_error (&opp->common, LIBERROR_BAD_ACTION,
1521181254a7Smrg 	      "Cannot set write lock on file opened for READ");
1522181254a7Smrg 	  return -1;
1523181254a7Smrg 	}
1524181254a7Smrg       f.l_type = F_WRLCK;
1525181254a7Smrg       r = fcntl (fd, F_SETLK, &f);
1526181254a7Smrg       break;
1527181254a7Smrg     case SHARE_UNSPECIFIED:
1528181254a7Smrg     default:
1529181254a7Smrg       break;
1530181254a7Smrg   }
1531181254a7Smrg 
1532181254a7Smrg   return r;
1533181254a7Smrg }
1534181254a7Smrg #else
1535181254a7Smrg static int
open_share(st_parameter_open * opp,int fd,unit_flags * flags)1536181254a7Smrg open_share (st_parameter_open *opp __attribute__ ((unused)),
1537181254a7Smrg     int fd __attribute__ ((unused)),
1538181254a7Smrg     unit_flags *flags __attribute__ ((unused)))
1539181254a7Smrg {
1540181254a7Smrg   return 0;
1541181254a7Smrg }
1542181254a7Smrg #endif /* defined(HAVE_FCNTL) ... */
1543181254a7Smrg 
1544181254a7Smrg 
1545181254a7Smrg /* Wrapper around regular_file2, to make sure we free the path after
1546181254a7Smrg    we're done.  */
1547181254a7Smrg 
1548181254a7Smrg static int
regular_file(st_parameter_open * opp,unit_flags * flags)1549181254a7Smrg regular_file (st_parameter_open *opp, unit_flags *flags)
1550181254a7Smrg {
1551181254a7Smrg   char *path = fc_strdup (opp->file, opp->file_len);
1552181254a7Smrg   int fd = regular_file2 (path, opp, flags);
1553181254a7Smrg   free (path);
1554181254a7Smrg   return fd;
1555181254a7Smrg }
1556181254a7Smrg 
1557181254a7Smrg /* open_external()-- Open an external file, unix specific version.
1558181254a7Smrg    Change flags->action if it is ACTION_UNSPECIFIED on entry.
1559181254a7Smrg    Returns NULL on operating system error. */
1560181254a7Smrg 
1561181254a7Smrg stream *
open_external(st_parameter_open * opp,unit_flags * flags)1562181254a7Smrg open_external (st_parameter_open *opp, unit_flags *flags)
1563181254a7Smrg {
1564181254a7Smrg   int fd;
1565181254a7Smrg 
1566181254a7Smrg   if (flags->status == STATUS_SCRATCH)
1567181254a7Smrg     {
1568181254a7Smrg       fd = tempfile (opp);
1569181254a7Smrg       if (flags->action == ACTION_UNSPECIFIED)
1570181254a7Smrg 	flags->action = flags->readonly ? ACTION_READ : ACTION_READWRITE;
1571181254a7Smrg 
1572181254a7Smrg #if HAVE_UNLINK_OPEN_FILE
1573181254a7Smrg       /* We can unlink scratch files now and it will go away when closed. */
1574181254a7Smrg       if (fd >= 0)
1575181254a7Smrg 	unlink (opp->file);
1576181254a7Smrg #endif
1577181254a7Smrg     }
1578181254a7Smrg   else
1579181254a7Smrg     {
1580181254a7Smrg       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1581181254a7Smrg          if it succeeds */
1582181254a7Smrg       fd = regular_file (opp, flags);
1583181254a7Smrg #ifndef O_CLOEXEC
1584181254a7Smrg       set_close_on_exec (fd);
1585181254a7Smrg #endif
1586181254a7Smrg     }
1587181254a7Smrg 
1588181254a7Smrg   if (fd < 0)
1589181254a7Smrg     return NULL;
1590181254a7Smrg   fd = fix_fd (fd);
1591181254a7Smrg 
1592181254a7Smrg   if (open_share (opp, fd, flags) < 0)
1593181254a7Smrg     return NULL;
1594181254a7Smrg 
1595181254a7Smrg   return fd_to_stream (fd, flags->form == FORM_UNFORMATTED);
1596181254a7Smrg }
1597181254a7Smrg 
1598181254a7Smrg 
1599181254a7Smrg /* input_stream()-- Return a stream pointer to the default input stream.
1600181254a7Smrg    Called on initialization. */
1601181254a7Smrg 
1602181254a7Smrg stream *
input_stream(void)1603181254a7Smrg input_stream (void)
1604181254a7Smrg {
1605181254a7Smrg   return fd_to_stream (STDIN_FILENO, false);
1606181254a7Smrg }
1607181254a7Smrg 
1608181254a7Smrg 
1609181254a7Smrg /* output_stream()-- Return a stream pointer to the default output stream.
1610181254a7Smrg    Called on initialization. */
1611181254a7Smrg 
1612181254a7Smrg stream *
output_stream(void)1613181254a7Smrg output_stream (void)
1614181254a7Smrg {
1615181254a7Smrg   stream *s;
1616181254a7Smrg 
1617181254a7Smrg #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1618181254a7Smrg   setmode (STDOUT_FILENO, O_BINARY);
1619181254a7Smrg #endif
1620181254a7Smrg 
1621181254a7Smrg   s = fd_to_stream (STDOUT_FILENO, false);
1622181254a7Smrg   return s;
1623181254a7Smrg }
1624181254a7Smrg 
1625181254a7Smrg 
1626181254a7Smrg /* error_stream()-- Return a stream pointer to the default error stream.
1627181254a7Smrg    Called on initialization. */
1628181254a7Smrg 
1629181254a7Smrg stream *
error_stream(void)1630181254a7Smrg error_stream (void)
1631181254a7Smrg {
1632181254a7Smrg   stream *s;
1633181254a7Smrg 
1634181254a7Smrg #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1635181254a7Smrg   setmode (STDERR_FILENO, O_BINARY);
1636181254a7Smrg #endif
1637181254a7Smrg 
1638181254a7Smrg   s = fd_to_stream (STDERR_FILENO, false);
1639181254a7Smrg   return s;
1640181254a7Smrg }
1641181254a7Smrg 
1642181254a7Smrg 
1643181254a7Smrg /* compare_file_filename()-- Given an open stream and a fortran string
1644181254a7Smrg    that is a filename, figure out if the file is the same as the
1645181254a7Smrg    filename. */
1646181254a7Smrg 
1647181254a7Smrg int
compare_file_filename(gfc_unit * u,const char * name,gfc_charlen_type len)1648181254a7Smrg compare_file_filename (gfc_unit *u, const char *name, gfc_charlen_type len)
1649181254a7Smrg {
1650181254a7Smrg   struct stat st;
1651181254a7Smrg   int ret;
1652181254a7Smrg #ifdef HAVE_WORKING_STAT
1653181254a7Smrg   unix_stream *s;
1654181254a7Smrg #else
1655181254a7Smrg # ifdef __MINGW32__
1656181254a7Smrg   uint64_t id1, id2;
1657181254a7Smrg # endif
1658181254a7Smrg #endif
1659181254a7Smrg 
1660181254a7Smrg   char *path = fc_strdup (name, len);
1661181254a7Smrg 
1662181254a7Smrg   /* If the filename doesn't exist, then there is no match with the
1663181254a7Smrg      existing file. */
1664181254a7Smrg 
1665181254a7Smrg   if (TEMP_FAILURE_RETRY (stat (path, &st)) < 0)
1666181254a7Smrg     {
1667181254a7Smrg       ret = 0;
1668181254a7Smrg       goto done;
1669181254a7Smrg     }
1670181254a7Smrg 
1671181254a7Smrg #ifdef HAVE_WORKING_STAT
1672181254a7Smrg   s = (unix_stream *) (u->s);
1673181254a7Smrg   ret = (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1674181254a7Smrg   goto done;
1675181254a7Smrg #else
1676181254a7Smrg 
1677181254a7Smrg # ifdef __MINGW32__
1678181254a7Smrg   /* We try to match files by a unique ID.  On some filesystems (network
1679181254a7Smrg      fs and FAT), we can't generate this unique ID, and will simply compare
1680181254a7Smrg      filenames.  */
1681181254a7Smrg   id1 = id_from_path (path);
1682181254a7Smrg   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1683181254a7Smrg   if (id1 || id2)
1684181254a7Smrg     {
1685181254a7Smrg       ret = (id1 == id2);
1686181254a7Smrg       goto done;
1687181254a7Smrg     }
1688181254a7Smrg # endif
1689181254a7Smrg   if (u->filename)
1690181254a7Smrg     ret = (strcmp(path, u->filename) == 0);
1691181254a7Smrg   else
1692181254a7Smrg     ret = 0;
1693181254a7Smrg #endif
1694181254a7Smrg  done:
1695181254a7Smrg   free (path);
1696181254a7Smrg   return ret;
1697181254a7Smrg }
1698181254a7Smrg 
1699181254a7Smrg 
1700181254a7Smrg #ifdef HAVE_WORKING_STAT
1701181254a7Smrg # define FIND_FILE0_DECL struct stat *st
1702181254a7Smrg # define FIND_FILE0_ARGS st
1703181254a7Smrg #else
1704181254a7Smrg # define FIND_FILE0_DECL uint64_t id, const char *path
1705181254a7Smrg # define FIND_FILE0_ARGS id, path
1706181254a7Smrg #endif
1707181254a7Smrg 
1708181254a7Smrg /* find_file0()-- Recursive work function for find_file() */
1709181254a7Smrg 
1710181254a7Smrg static gfc_unit *
find_file0(gfc_unit * u,FIND_FILE0_DECL)1711181254a7Smrg find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1712181254a7Smrg {
1713181254a7Smrg   gfc_unit *v;
1714181254a7Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1715181254a7Smrg   uint64_t id1;
1716181254a7Smrg #endif
1717181254a7Smrg 
1718181254a7Smrg   if (u == NULL)
1719181254a7Smrg     return NULL;
1720181254a7Smrg 
1721181254a7Smrg #ifdef HAVE_WORKING_STAT
1722181254a7Smrg   if (u->s != NULL)
1723181254a7Smrg     {
1724181254a7Smrg       unix_stream *s = (unix_stream *) (u->s);
1725181254a7Smrg       if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1726181254a7Smrg 	return u;
1727181254a7Smrg     }
1728181254a7Smrg #else
1729181254a7Smrg # ifdef __MINGW32__
1730181254a7Smrg   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1731181254a7Smrg     {
1732181254a7Smrg       if (id == id1)
1733181254a7Smrg 	return u;
1734181254a7Smrg     }
1735181254a7Smrg   else
1736181254a7Smrg # endif
1737181254a7Smrg     if (u->filename && strcmp (u->filename, path) == 0)
1738181254a7Smrg       return u;
1739181254a7Smrg #endif
1740181254a7Smrg 
1741181254a7Smrg   v = find_file0 (u->left, FIND_FILE0_ARGS);
1742181254a7Smrg   if (v != NULL)
1743181254a7Smrg     return v;
1744181254a7Smrg 
1745181254a7Smrg   v = find_file0 (u->right, FIND_FILE0_ARGS);
1746181254a7Smrg   if (v != NULL)
1747181254a7Smrg     return v;
1748181254a7Smrg 
1749181254a7Smrg   return NULL;
1750181254a7Smrg }
1751181254a7Smrg 
1752181254a7Smrg 
1753181254a7Smrg /* find_file()-- Take the current filename and see if there is a unit
1754181254a7Smrg    that has the file already open.  Returns a pointer to the unit if so. */
1755181254a7Smrg 
1756181254a7Smrg gfc_unit *
find_file(const char * file,gfc_charlen_type file_len)1757181254a7Smrg find_file (const char *file, gfc_charlen_type file_len)
1758181254a7Smrg {
1759181254a7Smrg   struct stat st[1];
1760181254a7Smrg   gfc_unit *u;
1761181254a7Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1762181254a7Smrg   uint64_t id = 0ULL;
1763181254a7Smrg #endif
1764181254a7Smrg 
1765181254a7Smrg   char *path = fc_strdup (file, file_len);
1766181254a7Smrg 
1767181254a7Smrg   if (TEMP_FAILURE_RETRY (stat (path, &st[0])) < 0)
1768181254a7Smrg     {
1769181254a7Smrg       u = NULL;
1770181254a7Smrg       goto done;
1771181254a7Smrg     }
1772181254a7Smrg 
1773181254a7Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1774181254a7Smrg   id = id_from_path (path);
1775181254a7Smrg #endif
1776181254a7Smrg 
1777181254a7Smrg   LOCK (&unit_lock);
1778181254a7Smrg retry:
1779181254a7Smrg   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1780181254a7Smrg   if (u != NULL)
1781181254a7Smrg     {
1782181254a7Smrg       /* Fast path.  */
1783181254a7Smrg       if (! __gthread_mutex_trylock (&u->lock))
1784181254a7Smrg 	{
1785181254a7Smrg 	  /* assert (u->closed == 0); */
1786181254a7Smrg 	  UNLOCK (&unit_lock);
1787181254a7Smrg 	  goto done;
1788181254a7Smrg 	}
1789181254a7Smrg 
1790181254a7Smrg       inc_waiting_locked (u);
1791181254a7Smrg     }
1792181254a7Smrg   UNLOCK (&unit_lock);
1793181254a7Smrg   if (u != NULL)
1794181254a7Smrg     {
1795181254a7Smrg       LOCK (&u->lock);
1796181254a7Smrg       if (u->closed)
1797181254a7Smrg 	{
1798181254a7Smrg 	  LOCK (&unit_lock);
1799181254a7Smrg 	  UNLOCK (&u->lock);
1800181254a7Smrg 	  if (predec_waiting_locked (u) == 0)
1801181254a7Smrg 	    free (u);
1802181254a7Smrg 	  goto retry;
1803181254a7Smrg 	}
1804181254a7Smrg 
1805181254a7Smrg       dec_waiting_unlocked (u);
1806181254a7Smrg     }
1807181254a7Smrg  done:
1808181254a7Smrg   free (path);
1809181254a7Smrg   return u;
1810181254a7Smrg }
1811181254a7Smrg 
1812181254a7Smrg static gfc_unit *
flush_all_units_1(gfc_unit * u,int min_unit)1813181254a7Smrg flush_all_units_1 (gfc_unit *u, int min_unit)
1814181254a7Smrg {
1815181254a7Smrg   while (u != NULL)
1816181254a7Smrg     {
1817181254a7Smrg       if (u->unit_number > min_unit)
1818181254a7Smrg 	{
1819181254a7Smrg 	  gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1820181254a7Smrg 	  if (r != NULL)
1821181254a7Smrg 	    return r;
1822181254a7Smrg 	}
1823181254a7Smrg       if (u->unit_number >= min_unit)
1824181254a7Smrg 	{
1825181254a7Smrg 	  if (__gthread_mutex_trylock (&u->lock))
1826181254a7Smrg 	    return u;
1827181254a7Smrg 	  if (u->s)
1828181254a7Smrg 	    sflush (u->s);
1829181254a7Smrg 	  UNLOCK (&u->lock);
1830181254a7Smrg 	}
1831181254a7Smrg       u = u->right;
1832181254a7Smrg     }
1833181254a7Smrg   return NULL;
1834181254a7Smrg }
1835181254a7Smrg 
1836181254a7Smrg void
flush_all_units(void)1837181254a7Smrg flush_all_units (void)
1838181254a7Smrg {
1839181254a7Smrg   gfc_unit *u;
1840181254a7Smrg   int min_unit = 0;
1841181254a7Smrg 
1842181254a7Smrg   LOCK (&unit_lock);
1843181254a7Smrg   do
1844181254a7Smrg     {
1845181254a7Smrg       u = flush_all_units_1 (unit_root, min_unit);
1846181254a7Smrg       if (u != NULL)
1847181254a7Smrg 	inc_waiting_locked (u);
1848181254a7Smrg       UNLOCK (&unit_lock);
1849181254a7Smrg       if (u == NULL)
1850181254a7Smrg 	return;
1851181254a7Smrg 
1852181254a7Smrg       LOCK (&u->lock);
1853181254a7Smrg 
1854181254a7Smrg       min_unit = u->unit_number + 1;
1855181254a7Smrg 
1856181254a7Smrg       if (u->closed == 0)
1857181254a7Smrg 	{
1858181254a7Smrg 	  sflush (u->s);
1859181254a7Smrg 	  LOCK (&unit_lock);
1860181254a7Smrg 	  UNLOCK (&u->lock);
1861181254a7Smrg 	  (void) predec_waiting_locked (u);
1862181254a7Smrg 	}
1863181254a7Smrg       else
1864181254a7Smrg 	{
1865181254a7Smrg 	  LOCK (&unit_lock);
1866181254a7Smrg 	  UNLOCK (&u->lock);
1867181254a7Smrg 	  if (predec_waiting_locked (u) == 0)
1868181254a7Smrg 	    free (u);
1869181254a7Smrg 	}
1870181254a7Smrg     }
1871181254a7Smrg   while (1);
1872181254a7Smrg }
1873181254a7Smrg 
1874181254a7Smrg 
1875181254a7Smrg /* Unlock the unit if necessary, based on SHARE flags.  */
1876181254a7Smrg 
1877181254a7Smrg int
close_share(gfc_unit * u)1878181254a7Smrg close_share (gfc_unit *u __attribute__ ((unused)))
1879181254a7Smrg {
1880181254a7Smrg   int r = 0;
1881181254a7Smrg #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1882181254a7Smrg   unix_stream *s = (unix_stream *) u->s;
1883181254a7Smrg   int fd = s->fd;
1884181254a7Smrg   struct flock f;
1885181254a7Smrg 
1886181254a7Smrg   switch (u->flags.share)
1887181254a7Smrg   {
1888181254a7Smrg     case SHARE_DENYRW:
1889181254a7Smrg     case SHARE_DENYNONE:
1890181254a7Smrg       if (fd != STDOUT_FILENO && fd != STDERR_FILENO && fd != STDIN_FILENO)
1891181254a7Smrg 	{
1892181254a7Smrg 	  f.l_start = 0;
1893181254a7Smrg 	  f.l_len = 0;
1894181254a7Smrg 	  f.l_whence = SEEK_SET;
1895181254a7Smrg 	  f.l_type = F_UNLCK;
1896181254a7Smrg 	  r = fcntl (fd, F_SETLK, &f);
1897181254a7Smrg 	}
1898181254a7Smrg       break;
1899181254a7Smrg     case SHARE_UNSPECIFIED:
1900181254a7Smrg     default:
1901181254a7Smrg       break;
1902181254a7Smrg   }
1903181254a7Smrg 
1904181254a7Smrg #endif
1905181254a7Smrg   return r;
1906181254a7Smrg }
1907181254a7Smrg 
1908181254a7Smrg 
1909181254a7Smrg /* file_exists()-- Returns nonzero if the current filename exists on
1910181254a7Smrg    the system */
1911181254a7Smrg 
1912181254a7Smrg int
file_exists(const char * file,gfc_charlen_type file_len)1913181254a7Smrg file_exists (const char *file, gfc_charlen_type file_len)
1914181254a7Smrg {
1915181254a7Smrg   char *path = fc_strdup (file, file_len);
1916181254a7Smrg   int res = !(access (path, F_OK));
1917181254a7Smrg   free (path);
1918181254a7Smrg   return res;
1919181254a7Smrg }
1920181254a7Smrg 
1921181254a7Smrg 
1922181254a7Smrg /* file_size()-- Returns the size of the file.  */
1923181254a7Smrg 
1924181254a7Smrg GFC_IO_INT
file_size(const char * file,gfc_charlen_type file_len)1925181254a7Smrg file_size (const char *file, gfc_charlen_type file_len)
1926181254a7Smrg {
1927181254a7Smrg   char *path = fc_strdup (file, file_len);
1928181254a7Smrg   struct stat statbuf;
1929181254a7Smrg   int err;
1930181254a7Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1931181254a7Smrg   free (path);
1932181254a7Smrg   if (err == -1)
1933181254a7Smrg     return -1;
1934181254a7Smrg   return (GFC_IO_INT) statbuf.st_size;
1935181254a7Smrg }
1936181254a7Smrg 
1937181254a7Smrg static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1938181254a7Smrg 
1939181254a7Smrg /* inquire_sequential()-- Given a fortran string, determine if the
1940181254a7Smrg    file is suitable for sequential access.  Returns a C-style
1941181254a7Smrg    string. */
1942181254a7Smrg 
1943181254a7Smrg const char *
inquire_sequential(const char * string,gfc_charlen_type len)1944181254a7Smrg inquire_sequential (const char *string, gfc_charlen_type len)
1945181254a7Smrg {
1946181254a7Smrg   struct stat statbuf;
1947181254a7Smrg 
1948181254a7Smrg   if (string == NULL)
1949181254a7Smrg     return unknown;
1950181254a7Smrg 
1951181254a7Smrg   char *path = fc_strdup (string, len);
1952181254a7Smrg   int err;
1953181254a7Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1954181254a7Smrg   free (path);
1955181254a7Smrg   if (err == -1)
1956181254a7Smrg     return unknown;
1957181254a7Smrg 
1958181254a7Smrg   if (S_ISREG (statbuf.st_mode) ||
1959181254a7Smrg       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1960181254a7Smrg     return unknown;
1961181254a7Smrg 
1962181254a7Smrg   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1963181254a7Smrg     return no;
1964181254a7Smrg 
1965181254a7Smrg   return unknown;
1966181254a7Smrg }
1967181254a7Smrg 
1968181254a7Smrg 
1969181254a7Smrg /* inquire_direct()-- Given a fortran string, determine if the file is
1970181254a7Smrg    suitable for direct access.  Returns a C-style string. */
1971181254a7Smrg 
1972181254a7Smrg const char *
inquire_direct(const char * string,gfc_charlen_type len)1973181254a7Smrg inquire_direct (const char *string, gfc_charlen_type len)
1974181254a7Smrg {
1975181254a7Smrg   struct stat statbuf;
1976181254a7Smrg 
1977181254a7Smrg   if (string == NULL)
1978181254a7Smrg     return unknown;
1979181254a7Smrg 
1980181254a7Smrg   char *path = fc_strdup (string, len);
1981181254a7Smrg   int err;
1982181254a7Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1983181254a7Smrg   free (path);
1984181254a7Smrg   if (err == -1)
1985181254a7Smrg     return unknown;
1986181254a7Smrg 
1987181254a7Smrg   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1988181254a7Smrg     return unknown;
1989181254a7Smrg 
1990181254a7Smrg   if (S_ISDIR (statbuf.st_mode) ||
1991181254a7Smrg       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1992181254a7Smrg     return no;
1993181254a7Smrg 
1994181254a7Smrg   return unknown;
1995181254a7Smrg }
1996181254a7Smrg 
1997181254a7Smrg 
1998181254a7Smrg /* inquire_formatted()-- Given a fortran string, determine if the file
1999181254a7Smrg    is suitable for formatted form.  Returns a C-style string. */
2000181254a7Smrg 
2001181254a7Smrg const char *
inquire_formatted(const char * string,gfc_charlen_type len)2002181254a7Smrg inquire_formatted (const char *string, gfc_charlen_type len)
2003181254a7Smrg {
2004181254a7Smrg   struct stat statbuf;
2005181254a7Smrg 
2006181254a7Smrg   if (string == NULL)
2007181254a7Smrg     return unknown;
2008181254a7Smrg 
2009181254a7Smrg   char *path = fc_strdup (string, len);
2010181254a7Smrg   int err;
2011181254a7Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
2012181254a7Smrg   free (path);
2013181254a7Smrg   if (err == -1)
2014181254a7Smrg     return unknown;
2015181254a7Smrg 
2016181254a7Smrg   if (S_ISREG (statbuf.st_mode) ||
2017181254a7Smrg       S_ISBLK (statbuf.st_mode) ||
2018181254a7Smrg       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
2019181254a7Smrg     return unknown;
2020181254a7Smrg 
2021181254a7Smrg   if (S_ISDIR (statbuf.st_mode))
2022181254a7Smrg     return no;
2023181254a7Smrg 
2024181254a7Smrg   return unknown;
2025181254a7Smrg }
2026181254a7Smrg 
2027181254a7Smrg 
2028181254a7Smrg /* inquire_unformatted()-- Given a fortran string, determine if the file
2029181254a7Smrg    is suitable for unformatted form.  Returns a C-style string. */
2030181254a7Smrg 
2031181254a7Smrg const char *
inquire_unformatted(const char * string,gfc_charlen_type len)2032181254a7Smrg inquire_unformatted (const char *string, gfc_charlen_type len)
2033181254a7Smrg {
2034181254a7Smrg   return inquire_formatted (string, len);
2035181254a7Smrg }
2036181254a7Smrg 
2037181254a7Smrg 
2038181254a7Smrg /* inquire_access()-- Given a fortran string, determine if the file is
2039181254a7Smrg    suitable for access. */
2040181254a7Smrg 
2041181254a7Smrg static const char *
inquire_access(const char * string,gfc_charlen_type len,int mode)2042181254a7Smrg inquire_access (const char *string, gfc_charlen_type len, int mode)
2043181254a7Smrg {
2044181254a7Smrg   if (string == NULL)
2045181254a7Smrg     return no;
2046181254a7Smrg   char *path = fc_strdup (string, len);
2047181254a7Smrg   int res = access (path, mode);
2048181254a7Smrg   free (path);
2049181254a7Smrg   if (res == -1)
2050181254a7Smrg     return no;
2051181254a7Smrg 
2052181254a7Smrg   return yes;
2053181254a7Smrg }
2054181254a7Smrg 
2055181254a7Smrg 
2056181254a7Smrg /* inquire_read()-- Given a fortran string, determine if the file is
2057181254a7Smrg    suitable for READ access. */
2058181254a7Smrg 
2059181254a7Smrg const char *
inquire_read(const char * string,gfc_charlen_type len)2060181254a7Smrg inquire_read (const char *string, gfc_charlen_type len)
2061181254a7Smrg {
2062181254a7Smrg   return inquire_access (string, len, R_OK);
2063181254a7Smrg }
2064181254a7Smrg 
2065181254a7Smrg 
2066181254a7Smrg /* inquire_write()-- Given a fortran string, determine if the file is
2067181254a7Smrg    suitable for READ access. */
2068181254a7Smrg 
2069181254a7Smrg const char *
inquire_write(const char * string,gfc_charlen_type len)2070181254a7Smrg inquire_write (const char *string, gfc_charlen_type len)
2071181254a7Smrg {
2072181254a7Smrg   return inquire_access (string, len, W_OK);
2073181254a7Smrg }
2074181254a7Smrg 
2075181254a7Smrg 
2076181254a7Smrg /* inquire_readwrite()-- Given a fortran string, determine if the file is
2077181254a7Smrg    suitable for read and write access. */
2078181254a7Smrg 
2079181254a7Smrg const char *
inquire_readwrite(const char * string,gfc_charlen_type len)2080181254a7Smrg inquire_readwrite (const char *string, gfc_charlen_type len)
2081181254a7Smrg {
2082181254a7Smrg   return inquire_access (string, len, R_OK | W_OK);
2083181254a7Smrg }
2084181254a7Smrg 
2085181254a7Smrg 
2086181254a7Smrg int
stream_isatty(stream * s)2087181254a7Smrg stream_isatty (stream *s)
2088181254a7Smrg {
2089181254a7Smrg   return isatty (((unix_stream *) s)->fd);
2090181254a7Smrg }
2091181254a7Smrg 
2092181254a7Smrg int
stream_ttyname(stream * s,char * buf,size_t buflen)2093181254a7Smrg stream_ttyname (stream *s  __attribute__ ((unused)),
2094181254a7Smrg 		char *buf  __attribute__ ((unused)),
2095181254a7Smrg 		size_t buflen  __attribute__ ((unused)))
2096181254a7Smrg {
2097181254a7Smrg #ifdef HAVE_TTYNAME_R
2098181254a7Smrg   return ttyname_r (((unix_stream *)s)->fd, buf, buflen);
2099181254a7Smrg #elif defined HAVE_TTYNAME
2100181254a7Smrg   char *p;
2101181254a7Smrg   size_t plen;
2102181254a7Smrg   p = ttyname (((unix_stream *)s)->fd);
2103181254a7Smrg   if (!p)
2104181254a7Smrg     return errno;
2105181254a7Smrg   plen = strlen (p);
2106181254a7Smrg   if (buflen < plen)
2107181254a7Smrg     plen = buflen;
2108181254a7Smrg   memcpy (buf, p, plen);
2109181254a7Smrg   return 0;
2110181254a7Smrg #else
2111181254a7Smrg   return ENOSYS;
2112181254a7Smrg #endif
2113181254a7Smrg }
2114181254a7Smrg 
2115181254a7Smrg 
2116181254a7Smrg 
2117181254a7Smrg 
2118181254a7Smrg /* How files are stored:  This is an operating-system specific issue,
2119181254a7Smrg    and therefore belongs here.  There are three cases to consider.
2120181254a7Smrg 
2121181254a7Smrg    Direct Access:
2122181254a7Smrg       Records are written as block of bytes corresponding to the record
2123181254a7Smrg       length of the file.  This goes for both formatted and unformatted
2124181254a7Smrg       records.  Positioning is done explicitly for each data transfer,
2125181254a7Smrg       so positioning is not much of an issue.
2126181254a7Smrg 
2127181254a7Smrg    Sequential Formatted:
2128181254a7Smrg       Records are separated by newline characters.  The newline character
2129181254a7Smrg       is prohibited from appearing in a string.  If it does, this will be
2130181254a7Smrg       messed up on the next read.  End of file is also the end of a record.
2131181254a7Smrg 
2132181254a7Smrg    Sequential Unformatted:
2133181254a7Smrg       In this case, we are merely copying bytes to and from main storage,
2134181254a7Smrg       yet we need to keep track of varying record lengths.  We adopt
2135181254a7Smrg       the solution used by f2c.  Each record contains a pair of length
2136181254a7Smrg       markers:
2137181254a7Smrg 
2138181254a7Smrg 	Length of record n in bytes
2139181254a7Smrg 	Data of record n
2140181254a7Smrg 	Length of record n in bytes
2141181254a7Smrg 
2142181254a7Smrg 	Length of record n+1 in bytes
2143181254a7Smrg 	Data of record n+1
2144181254a7Smrg 	Length of record n+1 in bytes
2145181254a7Smrg 
2146181254a7Smrg      The length is stored at the end of a record to allow backspacing to the
2147181254a7Smrg      previous record.  Between data transfer statements, the file pointer
2148181254a7Smrg      is left pointing to the first length of the current record.
2149181254a7Smrg 
2150181254a7Smrg      ENDFILE records are never explicitly stored.
2151181254a7Smrg 
2152181254a7Smrg */
2153