xref: /netbsd-src/external/gpl3/gcc.old/dist/libgfortran/io/unix.c (revision 4c3eb207d36f67d31994830c0a694161fc1ca39b)
1*4c3eb207Smrg /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2627f7eb2Smrg    Contributed by Andy Vaught
3627f7eb2Smrg    F2003 I/O support contributed by Jerry DeLisle
4627f7eb2Smrg 
5627f7eb2Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6627f7eb2Smrg 
7627f7eb2Smrg Libgfortran is free software; you can redistribute it and/or modify
8627f7eb2Smrg it under the terms of the GNU General Public License as published by
9627f7eb2Smrg the Free Software Foundation; either version 3, or (at your option)
10627f7eb2Smrg any later version.
11627f7eb2Smrg 
12627f7eb2Smrg Libgfortran is distributed in the hope that it will be useful,
13627f7eb2Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14627f7eb2Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15627f7eb2Smrg GNU General Public License for more details.
16627f7eb2Smrg 
17627f7eb2Smrg Under Section 7 of GPL version 3, you are granted additional
18627f7eb2Smrg permissions described in the GCC Runtime Library Exception, version
19627f7eb2Smrg 3.1, as published by the Free Software Foundation.
20627f7eb2Smrg 
21627f7eb2Smrg You should have received a copy of the GNU General Public License and
22627f7eb2Smrg a copy of the GCC Runtime Library Exception along with this program;
23627f7eb2Smrg see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24627f7eb2Smrg <http://www.gnu.org/licenses/>.  */
25627f7eb2Smrg 
26627f7eb2Smrg /* Unix stream I/O module */
27627f7eb2Smrg 
28627f7eb2Smrg #include "io.h"
29627f7eb2Smrg #include "unix.h"
30627f7eb2Smrg #include "async.h"
31627f7eb2Smrg #include <limits.h>
32627f7eb2Smrg 
33627f7eb2Smrg #ifdef HAVE_UNISTD_H
34627f7eb2Smrg #include <unistd.h>
35627f7eb2Smrg #endif
36627f7eb2Smrg 
37627f7eb2Smrg #include <sys/stat.h>
38627f7eb2Smrg #include <fcntl.h>
39627f7eb2Smrg 
40627f7eb2Smrg #include <string.h>
41627f7eb2Smrg #include <errno.h>
42627f7eb2Smrg 
43627f7eb2Smrg 
44627f7eb2Smrg /* For mingw, we don't identify files by their inode number, but by a
45627f7eb2Smrg    64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
46627f7eb2Smrg #ifdef __MINGW32__
47627f7eb2Smrg 
48627f7eb2Smrg #define WIN32_LEAN_AND_MEAN
49627f7eb2Smrg #include <windows.h>
50627f7eb2Smrg 
51627f7eb2Smrg #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
52627f7eb2Smrg #undef lseek
53627f7eb2Smrg #define lseek _lseeki64
54627f7eb2Smrg #undef fstat
55627f7eb2Smrg #define fstat _fstati64
56627f7eb2Smrg #undef stat
57627f7eb2Smrg #define stat _stati64
58627f7eb2Smrg #endif
59627f7eb2Smrg 
60627f7eb2Smrg #ifndef HAVE_WORKING_STAT
61627f7eb2Smrg static uint64_t
id_from_handle(HANDLE hFile)62627f7eb2Smrg id_from_handle (HANDLE hFile)
63627f7eb2Smrg {
64627f7eb2Smrg   BY_HANDLE_FILE_INFORMATION FileInformation;
65627f7eb2Smrg 
66627f7eb2Smrg   if (hFile == INVALID_HANDLE_VALUE)
67627f7eb2Smrg       return 0;
68627f7eb2Smrg 
69627f7eb2Smrg   memset (&FileInformation, 0, sizeof(FileInformation));
70627f7eb2Smrg   if (!GetFileInformationByHandle (hFile, &FileInformation))
71627f7eb2Smrg     return 0;
72627f7eb2Smrg 
73627f7eb2Smrg   return ((uint64_t) FileInformation.nFileIndexLow)
74627f7eb2Smrg 	 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
75627f7eb2Smrg }
76627f7eb2Smrg 
77627f7eb2Smrg 
78627f7eb2Smrg static uint64_t
id_from_path(const char * path)79627f7eb2Smrg id_from_path (const char *path)
80627f7eb2Smrg {
81627f7eb2Smrg   HANDLE hFile;
82627f7eb2Smrg   uint64_t res;
83627f7eb2Smrg 
84627f7eb2Smrg   if (!path || !*path || access (path, F_OK))
85627f7eb2Smrg     return (uint64_t) -1;
86627f7eb2Smrg 
87627f7eb2Smrg   hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
88627f7eb2Smrg 		      FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
89627f7eb2Smrg 		      NULL);
90627f7eb2Smrg   res = id_from_handle (hFile);
91627f7eb2Smrg   CloseHandle (hFile);
92627f7eb2Smrg   return res;
93627f7eb2Smrg }
94627f7eb2Smrg 
95627f7eb2Smrg 
96627f7eb2Smrg static uint64_t
id_from_fd(const int fd)97627f7eb2Smrg id_from_fd (const int fd)
98627f7eb2Smrg {
99627f7eb2Smrg   return id_from_handle ((HANDLE) _get_osfhandle (fd));
100627f7eb2Smrg }
101627f7eb2Smrg 
102627f7eb2Smrg #endif /* HAVE_WORKING_STAT */
103627f7eb2Smrg 
104627f7eb2Smrg 
105627f7eb2Smrg /* On mingw, we don't use umask in tempfile_open(), because it
106627f7eb2Smrg    doesn't support the user/group/other-based permissions.  */
107627f7eb2Smrg #undef HAVE_UMASK
108627f7eb2Smrg 
109627f7eb2Smrg #endif /* __MINGW32__ */
110627f7eb2Smrg 
111627f7eb2Smrg 
112627f7eb2Smrg /* These flags aren't defined on all targets (mingw32), so provide them
113627f7eb2Smrg    here.  */
114627f7eb2Smrg #ifndef S_IRGRP
115627f7eb2Smrg #define S_IRGRP 0
116627f7eb2Smrg #endif
117627f7eb2Smrg 
118627f7eb2Smrg #ifndef S_IWGRP
119627f7eb2Smrg #define S_IWGRP 0
120627f7eb2Smrg #endif
121627f7eb2Smrg 
122627f7eb2Smrg #ifndef S_IROTH
123627f7eb2Smrg #define S_IROTH 0
124627f7eb2Smrg #endif
125627f7eb2Smrg 
126627f7eb2Smrg #ifndef S_IWOTH
127627f7eb2Smrg #define S_IWOTH 0
128627f7eb2Smrg #endif
129627f7eb2Smrg 
130627f7eb2Smrg 
131627f7eb2Smrg #ifndef HAVE_ACCESS
132627f7eb2Smrg 
133627f7eb2Smrg #ifndef W_OK
134627f7eb2Smrg #define W_OK 2
135627f7eb2Smrg #endif
136627f7eb2Smrg 
137627f7eb2Smrg #ifndef R_OK
138627f7eb2Smrg #define R_OK 4
139627f7eb2Smrg #endif
140627f7eb2Smrg 
141627f7eb2Smrg #ifndef F_OK
142627f7eb2Smrg #define F_OK 0
143627f7eb2Smrg #endif
144627f7eb2Smrg 
145627f7eb2Smrg /* Fallback implementation of access() on systems that don't have it.
146627f7eb2Smrg    Only modes R_OK, W_OK and F_OK are used in this file.  */
147627f7eb2Smrg 
148627f7eb2Smrg static int
fallback_access(const char * path,int mode)149627f7eb2Smrg fallback_access (const char *path, int mode)
150627f7eb2Smrg {
151627f7eb2Smrg   int fd;
152627f7eb2Smrg 
153627f7eb2Smrg   if (mode & R_OK)
154627f7eb2Smrg     {
155627f7eb2Smrg       if ((fd = open (path, O_RDONLY)) < 0)
156627f7eb2Smrg 	return -1;
157627f7eb2Smrg       else
158627f7eb2Smrg 	close (fd);
159627f7eb2Smrg     }
160627f7eb2Smrg 
161627f7eb2Smrg   if (mode & W_OK)
162627f7eb2Smrg     {
163627f7eb2Smrg       if ((fd = open (path, O_WRONLY)) < 0)
164627f7eb2Smrg 	return -1;
165627f7eb2Smrg       else
166627f7eb2Smrg 	close (fd);
167627f7eb2Smrg     }
168627f7eb2Smrg 
169627f7eb2Smrg   if (mode == F_OK)
170627f7eb2Smrg     {
171627f7eb2Smrg       struct stat st;
172627f7eb2Smrg       return stat (path, &st);
173627f7eb2Smrg     }
174627f7eb2Smrg 
175627f7eb2Smrg   return 0;
176627f7eb2Smrg }
177627f7eb2Smrg 
178627f7eb2Smrg #undef access
179627f7eb2Smrg #define access fallback_access
180627f7eb2Smrg #endif
181627f7eb2Smrg 
182627f7eb2Smrg 
183627f7eb2Smrg /* Fallback directory for creating temporary files.  P_tmpdir is
184627f7eb2Smrg    defined on many POSIX platforms.  */
185627f7eb2Smrg #ifndef P_tmpdir
186627f7eb2Smrg #ifdef _P_tmpdir
187627f7eb2Smrg #define P_tmpdir _P_tmpdir  /* MinGW */
188627f7eb2Smrg #else
189627f7eb2Smrg #define P_tmpdir "/tmp"
190627f7eb2Smrg #endif
191627f7eb2Smrg #endif
192627f7eb2Smrg 
193627f7eb2Smrg 
194627f7eb2Smrg /* Unix and internal stream I/O module */
195627f7eb2Smrg 
196627f7eb2Smrg static const int FORMATTED_BUFFER_SIZE_DEFAULT = 8192;
197627f7eb2Smrg static const int UNFORMATTED_BUFFER_SIZE_DEFAULT = 128*1024;
198627f7eb2Smrg 
199627f7eb2Smrg typedef struct
200627f7eb2Smrg {
201627f7eb2Smrg   stream st;
202627f7eb2Smrg 
203627f7eb2Smrg   gfc_offset buffer_offset;	/* File offset of the start of the buffer */
204627f7eb2Smrg   gfc_offset physical_offset;	/* Current physical file offset */
205627f7eb2Smrg   gfc_offset logical_offset;	/* Current logical file offset */
206627f7eb2Smrg   gfc_offset file_length;	/* Length of the file. */
207627f7eb2Smrg 
208627f7eb2Smrg   char *buffer;                 /* Pointer to the buffer.  */
209627f7eb2Smrg   ssize_t buffer_size;           /* Length of the buffer.  */
210627f7eb2Smrg   int fd;                       /* The POSIX file descriptor.  */
211627f7eb2Smrg 
212627f7eb2Smrg   int active;			/* Length of valid bytes in the buffer */
213627f7eb2Smrg 
214627f7eb2Smrg   int ndirty;			/* Dirty bytes starting at buffer_offset */
215627f7eb2Smrg 
216627f7eb2Smrg   /* Cached stat(2) values.  */
217627f7eb2Smrg   dev_t st_dev;
218627f7eb2Smrg   ino_t st_ino;
219627f7eb2Smrg 
220627f7eb2Smrg   bool unbuffered;  /* Buffer should be flushed after each I/O statement.  */
221627f7eb2Smrg }
222627f7eb2Smrg unix_stream;
223627f7eb2Smrg 
224627f7eb2Smrg 
225627f7eb2Smrg /* fix_fd()-- Given a file descriptor, make sure it is not one of the
226627f7eb2Smrg    standard descriptors, returning a non-standard descriptor.  If the
227627f7eb2Smrg    user specifies that system errors should go to standard output,
228627f7eb2Smrg    then closes standard output, we don't want the system errors to a
229627f7eb2Smrg    file that has been given file descriptor 1 or 0.  We want to send
230627f7eb2Smrg    the error to the invalid descriptor. */
231627f7eb2Smrg 
232627f7eb2Smrg static int
fix_fd(int fd)233627f7eb2Smrg fix_fd (int fd)
234627f7eb2Smrg {
235627f7eb2Smrg #ifdef HAVE_DUP
236627f7eb2Smrg   int input, output, error;
237627f7eb2Smrg 
238627f7eb2Smrg   input = output = error = 0;
239627f7eb2Smrg 
240627f7eb2Smrg   /* Unix allocates the lowest descriptors first, so a loop is not
241627f7eb2Smrg      required, but this order is. */
242627f7eb2Smrg   if (fd == STDIN_FILENO)
243627f7eb2Smrg     {
244627f7eb2Smrg       fd = dup (fd);
245627f7eb2Smrg       input = 1;
246627f7eb2Smrg     }
247627f7eb2Smrg   if (fd == STDOUT_FILENO)
248627f7eb2Smrg     {
249627f7eb2Smrg       fd = dup (fd);
250627f7eb2Smrg       output = 1;
251627f7eb2Smrg     }
252627f7eb2Smrg   if (fd == STDERR_FILENO)
253627f7eb2Smrg     {
254627f7eb2Smrg       fd = dup (fd);
255627f7eb2Smrg       error = 1;
256627f7eb2Smrg     }
257627f7eb2Smrg 
258627f7eb2Smrg   if (input)
259627f7eb2Smrg     close (STDIN_FILENO);
260627f7eb2Smrg   if (output)
261627f7eb2Smrg     close (STDOUT_FILENO);
262627f7eb2Smrg   if (error)
263627f7eb2Smrg     close (STDERR_FILENO);
264627f7eb2Smrg #endif
265627f7eb2Smrg 
266627f7eb2Smrg   return fd;
267627f7eb2Smrg }
268627f7eb2Smrg 
269627f7eb2Smrg 
270627f7eb2Smrg /* If the stream corresponds to a preconnected unit, we flush the
271627f7eb2Smrg    corresponding C stream.  This is bugware for mixed C-Fortran codes
272627f7eb2Smrg    where the C code doesn't flush I/O before returning.  */
273627f7eb2Smrg void
flush_if_preconnected(stream * s)274627f7eb2Smrg flush_if_preconnected (stream *s)
275627f7eb2Smrg {
276627f7eb2Smrg   int fd;
277627f7eb2Smrg 
278627f7eb2Smrg   fd = ((unix_stream *) s)->fd;
279627f7eb2Smrg   if (fd == STDIN_FILENO)
280627f7eb2Smrg     fflush (stdin);
281627f7eb2Smrg   else if (fd == STDOUT_FILENO)
282627f7eb2Smrg     fflush (stdout);
283627f7eb2Smrg   else if (fd == STDERR_FILENO)
284627f7eb2Smrg     fflush (stderr);
285627f7eb2Smrg }
286627f7eb2Smrg 
287627f7eb2Smrg 
288627f7eb2Smrg /********************************************************************
289627f7eb2Smrg Raw I/O functions (read, write, seek, tell, truncate, close).
290627f7eb2Smrg 
291627f7eb2Smrg These functions wrap the basic POSIX I/O syscalls. Any deviation in
292627f7eb2Smrg semantics is a bug, except the following: write restarts in case
293627f7eb2Smrg of being interrupted by a signal, and as the first argument the
294627f7eb2Smrg functions take the unix_stream struct rather than an integer file
295627f7eb2Smrg descriptor. Also, for POSIX read() and write() a nbyte argument larger
296627f7eb2Smrg than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
297627f7eb2Smrg than size_t as for POSIX read/write.
298627f7eb2Smrg *********************************************************************/
299627f7eb2Smrg 
300627f7eb2Smrg static int
raw_flush(unix_stream * s)301627f7eb2Smrg raw_flush (unix_stream *s  __attribute__ ((unused)))
302627f7eb2Smrg {
303627f7eb2Smrg   return 0;
304627f7eb2Smrg }
305627f7eb2Smrg 
306627f7eb2Smrg /* Write/read at most 2 GB - 4k chunks at a time. Linux never reads or
307627f7eb2Smrg    writes more than this, and there are reports that macOS fails for
308627f7eb2Smrg    larger than 2 GB as well.  */
309627f7eb2Smrg #define MAX_CHUNK 2147479552
310627f7eb2Smrg 
311627f7eb2Smrg static ssize_t
raw_read(unix_stream * s,void * buf,ssize_t nbyte)312627f7eb2Smrg raw_read (unix_stream *s, void *buf, ssize_t nbyte)
313627f7eb2Smrg {
314627f7eb2Smrg   /* For read we can't do I/O in a loop like raw_write does, because
315627f7eb2Smrg      that will break applications that wait for interactive I/O.  We
316627f7eb2Smrg      still can loop around EINTR, though.  This however causes a
317627f7eb2Smrg      problem for large reads which must be chunked, see comment above.
318627f7eb2Smrg      So assume that if the size is larger than the chunk size, we're
319627f7eb2Smrg      reading from a file and not the terminal.  */
320627f7eb2Smrg   if (nbyte <= MAX_CHUNK)
321627f7eb2Smrg     {
322627f7eb2Smrg       while (true)
323627f7eb2Smrg 	{
324627f7eb2Smrg 	  ssize_t trans = read (s->fd, buf, nbyte);
325627f7eb2Smrg 	  if (trans == -1 && errno == EINTR)
326627f7eb2Smrg 	    continue;
327627f7eb2Smrg 	  return trans;
328627f7eb2Smrg 	}
329627f7eb2Smrg     }
330627f7eb2Smrg   else
331627f7eb2Smrg     {
332627f7eb2Smrg       ssize_t bytes_left = nbyte;
333627f7eb2Smrg       char *buf_st = buf;
334627f7eb2Smrg       while (bytes_left > 0)
335627f7eb2Smrg 	{
336627f7eb2Smrg 	  ssize_t to_read = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
337627f7eb2Smrg 	  ssize_t trans = read (s->fd, buf_st, to_read);
338627f7eb2Smrg 	  if (trans == -1)
339627f7eb2Smrg 	    {
340627f7eb2Smrg 	      if (errno == EINTR)
341627f7eb2Smrg 		continue;
342627f7eb2Smrg 	      else
343627f7eb2Smrg 		return trans;
344627f7eb2Smrg 	    }
345627f7eb2Smrg 	  buf_st += trans;
346627f7eb2Smrg 	  bytes_left -= trans;
347627f7eb2Smrg 	}
348627f7eb2Smrg       return nbyte - bytes_left;
349627f7eb2Smrg     }
350627f7eb2Smrg }
351627f7eb2Smrg 
352627f7eb2Smrg static ssize_t
raw_write(unix_stream * s,const void * buf,ssize_t nbyte)353627f7eb2Smrg raw_write (unix_stream *s, const void *buf, ssize_t nbyte)
354627f7eb2Smrg {
355627f7eb2Smrg   ssize_t trans, bytes_left;
356627f7eb2Smrg   char *buf_st;
357627f7eb2Smrg 
358627f7eb2Smrg   bytes_left = nbyte;
359627f7eb2Smrg   buf_st = (char *) buf;
360627f7eb2Smrg 
361627f7eb2Smrg   /* We must write in a loop since some systems don't restart system
362627f7eb2Smrg      calls in case of a signal.  Also some systems might fail outright
363627f7eb2Smrg      if we try to write more than 2 GB in a single syscall, so chunk
364627f7eb2Smrg      up large writes.  */
365627f7eb2Smrg   while (bytes_left > 0)
366627f7eb2Smrg     {
367627f7eb2Smrg       ssize_t to_write = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
368627f7eb2Smrg       trans = write (s->fd, buf_st, to_write);
369627f7eb2Smrg       if (trans == -1)
370627f7eb2Smrg 	{
371627f7eb2Smrg 	  if (errno == EINTR)
372627f7eb2Smrg 	    continue;
373627f7eb2Smrg 	  else
374627f7eb2Smrg 	    return trans;
375627f7eb2Smrg 	}
376627f7eb2Smrg       buf_st += trans;
377627f7eb2Smrg       bytes_left -= trans;
378627f7eb2Smrg     }
379627f7eb2Smrg 
380627f7eb2Smrg   return nbyte - bytes_left;
381627f7eb2Smrg }
382627f7eb2Smrg 
383627f7eb2Smrg static gfc_offset
raw_seek(unix_stream * s,gfc_offset offset,int whence)384627f7eb2Smrg raw_seek (unix_stream *s, gfc_offset offset, int whence)
385627f7eb2Smrg {
386627f7eb2Smrg   while (true)
387627f7eb2Smrg     {
388627f7eb2Smrg       gfc_offset off = lseek (s->fd, offset, whence);
389627f7eb2Smrg       if (off == (gfc_offset) -1 && errno == EINTR)
390627f7eb2Smrg 	continue;
391627f7eb2Smrg       return off;
392627f7eb2Smrg     }
393627f7eb2Smrg }
394627f7eb2Smrg 
395627f7eb2Smrg static gfc_offset
raw_tell(unix_stream * s)396627f7eb2Smrg raw_tell (unix_stream *s)
397627f7eb2Smrg {
398627f7eb2Smrg   while (true)
399627f7eb2Smrg     {
400627f7eb2Smrg       gfc_offset off = lseek (s->fd, 0, SEEK_CUR);
401627f7eb2Smrg       if (off == (gfc_offset) -1 && errno == EINTR)
402627f7eb2Smrg 	continue;
403627f7eb2Smrg       return off;
404627f7eb2Smrg     }
405627f7eb2Smrg }
406627f7eb2Smrg 
407627f7eb2Smrg static gfc_offset
raw_size(unix_stream * s)408627f7eb2Smrg raw_size (unix_stream *s)
409627f7eb2Smrg {
410627f7eb2Smrg   struct stat statbuf;
411627f7eb2Smrg   if (TEMP_FAILURE_RETRY (fstat (s->fd, &statbuf)) == -1)
412627f7eb2Smrg     return -1;
413627f7eb2Smrg   if (S_ISREG (statbuf.st_mode))
414627f7eb2Smrg     return statbuf.st_size;
415627f7eb2Smrg   else
416627f7eb2Smrg     return 0;
417627f7eb2Smrg }
418627f7eb2Smrg 
419627f7eb2Smrg static int
raw_truncate(unix_stream * s,gfc_offset length)420627f7eb2Smrg raw_truncate (unix_stream *s, gfc_offset length)
421627f7eb2Smrg {
422627f7eb2Smrg #ifdef __MINGW32__
423627f7eb2Smrg   HANDLE h;
424627f7eb2Smrg   gfc_offset cur;
425627f7eb2Smrg 
426627f7eb2Smrg   if (isatty (s->fd))
427627f7eb2Smrg     {
428627f7eb2Smrg       errno = EBADF;
429627f7eb2Smrg       return -1;
430627f7eb2Smrg     }
431627f7eb2Smrg   h = (HANDLE) _get_osfhandle (s->fd);
432627f7eb2Smrg   if (h == INVALID_HANDLE_VALUE)
433627f7eb2Smrg     {
434627f7eb2Smrg       errno = EBADF;
435627f7eb2Smrg       return -1;
436627f7eb2Smrg     }
437627f7eb2Smrg   cur = lseek (s->fd, 0, SEEK_CUR);
438627f7eb2Smrg   if (cur == -1)
439627f7eb2Smrg     return -1;
440627f7eb2Smrg   if (lseek (s->fd, length, SEEK_SET) == -1)
441627f7eb2Smrg     goto error;
442627f7eb2Smrg   if (!SetEndOfFile (h))
443627f7eb2Smrg     {
444627f7eb2Smrg       errno = EBADF;
445627f7eb2Smrg       goto error;
446627f7eb2Smrg     }
447627f7eb2Smrg   if (lseek (s->fd, cur, SEEK_SET) == -1)
448627f7eb2Smrg     return -1;
449627f7eb2Smrg   return 0;
450627f7eb2Smrg  error:
451627f7eb2Smrg   lseek (s->fd, cur, SEEK_SET);
452627f7eb2Smrg   return -1;
453627f7eb2Smrg #elif defined HAVE_FTRUNCATE
454627f7eb2Smrg   if (TEMP_FAILURE_RETRY (ftruncate (s->fd, length)) == -1)
455627f7eb2Smrg     return -1;
456627f7eb2Smrg   return 0;
457627f7eb2Smrg #elif defined HAVE_CHSIZE
458627f7eb2Smrg   return chsize (s->fd, length);
459627f7eb2Smrg #else
460627f7eb2Smrg   runtime_error ("required ftruncate or chsize support not present");
461627f7eb2Smrg   return -1;
462627f7eb2Smrg #endif
463627f7eb2Smrg }
464627f7eb2Smrg 
465627f7eb2Smrg static int
raw_close(unix_stream * s)466627f7eb2Smrg raw_close (unix_stream *s)
467627f7eb2Smrg {
468627f7eb2Smrg   int retval;
469627f7eb2Smrg 
470627f7eb2Smrg   if (s->fd == -1)
471627f7eb2Smrg     retval = -1;
472627f7eb2Smrg   else if (s->fd != STDOUT_FILENO
473627f7eb2Smrg       && s->fd != STDERR_FILENO
474627f7eb2Smrg       && s->fd != STDIN_FILENO)
475627f7eb2Smrg     {
476627f7eb2Smrg       retval = close (s->fd);
477627f7eb2Smrg       /* close() and EINTR is special, as the file descriptor is
478627f7eb2Smrg 	 deallocated before doing anything that might cause the
479627f7eb2Smrg 	 operation to be interrupted. Thus if we get EINTR the best we
480627f7eb2Smrg 	 can do is ignore it and continue (otherwise if we try again
481627f7eb2Smrg 	 the file descriptor may have been allocated again to some
482627f7eb2Smrg 	 other file).  */
483627f7eb2Smrg       if (retval == -1 && errno == EINTR)
484627f7eb2Smrg 	retval = errno = 0;
485627f7eb2Smrg     }
486627f7eb2Smrg   else
487627f7eb2Smrg     retval = 0;
488627f7eb2Smrg   free (s);
489627f7eb2Smrg   return retval;
490627f7eb2Smrg }
491627f7eb2Smrg 
492627f7eb2Smrg static int
raw_markeor(unix_stream * s)493627f7eb2Smrg raw_markeor (unix_stream *s __attribute__ ((unused)))
494627f7eb2Smrg {
495627f7eb2Smrg   return 0;
496627f7eb2Smrg }
497627f7eb2Smrg 
498627f7eb2Smrg static const struct stream_vtable raw_vtable = {
499627f7eb2Smrg   .read = (void *) raw_read,
500627f7eb2Smrg   .write = (void *) raw_write,
501627f7eb2Smrg   .seek = (void *) raw_seek,
502627f7eb2Smrg   .tell = (void *) raw_tell,
503627f7eb2Smrg   .size = (void *) raw_size,
504627f7eb2Smrg   .trunc = (void *) raw_truncate,
505627f7eb2Smrg   .close = (void *) raw_close,
506627f7eb2Smrg   .flush = (void *) raw_flush,
507627f7eb2Smrg   .markeor = (void *) raw_markeor
508627f7eb2Smrg };
509627f7eb2Smrg 
510627f7eb2Smrg static int
raw_init(unix_stream * s)511627f7eb2Smrg raw_init (unix_stream *s)
512627f7eb2Smrg {
513627f7eb2Smrg   s->st.vptr = &raw_vtable;
514627f7eb2Smrg 
515627f7eb2Smrg   s->buffer = NULL;
516627f7eb2Smrg   return 0;
517627f7eb2Smrg }
518627f7eb2Smrg 
519627f7eb2Smrg 
520627f7eb2Smrg /*********************************************************************
521627f7eb2Smrg Buffered I/O functions. These functions have the same semantics as the
522627f7eb2Smrg raw I/O functions above, except that they are buffered in order to
523627f7eb2Smrg improve performance. The buffer must be flushed when switching from
524627f7eb2Smrg reading to writing and vice versa.
525627f7eb2Smrg *********************************************************************/
526627f7eb2Smrg 
527627f7eb2Smrg static int
buf_flush(unix_stream * s)528627f7eb2Smrg buf_flush (unix_stream *s)
529627f7eb2Smrg {
530627f7eb2Smrg   int writelen;
531627f7eb2Smrg 
532627f7eb2Smrg   /* Flushing in read mode means discarding read bytes.  */
533627f7eb2Smrg   s->active = 0;
534627f7eb2Smrg 
535627f7eb2Smrg   if (s->ndirty == 0)
536627f7eb2Smrg     return 0;
537627f7eb2Smrg 
538627f7eb2Smrg   if (s->physical_offset != s->buffer_offset
539627f7eb2Smrg       && raw_seek (s, s->buffer_offset, SEEK_SET) < 0)
540627f7eb2Smrg     return -1;
541627f7eb2Smrg 
542627f7eb2Smrg   writelen = raw_write (s, s->buffer, s->ndirty);
543627f7eb2Smrg 
544627f7eb2Smrg   s->physical_offset = s->buffer_offset + writelen;
545627f7eb2Smrg 
546627f7eb2Smrg   if (s->physical_offset > s->file_length)
547627f7eb2Smrg       s->file_length = s->physical_offset;
548627f7eb2Smrg 
549627f7eb2Smrg   s->ndirty -= writelen;
550627f7eb2Smrg   if (s->ndirty != 0)
551627f7eb2Smrg     return -1;
552627f7eb2Smrg 
553627f7eb2Smrg   return 0;
554627f7eb2Smrg }
555627f7eb2Smrg 
556627f7eb2Smrg static ssize_t
buf_read(unix_stream * s,void * buf,ssize_t nbyte)557627f7eb2Smrg buf_read (unix_stream *s, void *buf, ssize_t nbyte)
558627f7eb2Smrg {
559627f7eb2Smrg   if (s->active == 0)
560627f7eb2Smrg     s->buffer_offset = s->logical_offset;
561627f7eb2Smrg 
562627f7eb2Smrg   /* Is the data we want in the buffer?  */
563627f7eb2Smrg   if (s->logical_offset + nbyte <= s->buffer_offset + s->active
564627f7eb2Smrg       && s->buffer_offset <= s->logical_offset)
565627f7eb2Smrg     {
566627f7eb2Smrg       /* When nbyte == 0, buf can be NULL which would lead to undefined
567627f7eb2Smrg 	 behavior if we called memcpy().  */
568627f7eb2Smrg       if (nbyte != 0)
569627f7eb2Smrg 	memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
570627f7eb2Smrg 		nbyte);
571627f7eb2Smrg     }
572627f7eb2Smrg   else
573627f7eb2Smrg     {
574627f7eb2Smrg       /* First copy the active bytes if applicable, then read the rest
575627f7eb2Smrg          either directly or filling the buffer.  */
576627f7eb2Smrg       char *p;
577627f7eb2Smrg       int nread = 0;
578627f7eb2Smrg       ssize_t to_read, did_read;
579627f7eb2Smrg       gfc_offset new_logical;
580627f7eb2Smrg 
581627f7eb2Smrg       p = (char *) buf;
582627f7eb2Smrg       if (s->logical_offset >= s->buffer_offset
583627f7eb2Smrg           && s->buffer_offset + s->active >= s->logical_offset)
584627f7eb2Smrg         {
585627f7eb2Smrg           nread = s->active - (s->logical_offset - s->buffer_offset);
586627f7eb2Smrg           memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
587627f7eb2Smrg                   nread);
588627f7eb2Smrg           p += nread;
589627f7eb2Smrg         }
590627f7eb2Smrg       /* At this point we consider all bytes in the buffer discarded.  */
591627f7eb2Smrg       to_read = nbyte - nread;
592627f7eb2Smrg       new_logical = s->logical_offset + nread;
593627f7eb2Smrg       if (s->physical_offset != new_logical
594627f7eb2Smrg           && raw_seek (s, new_logical, SEEK_SET) < 0)
595627f7eb2Smrg         return -1;
596627f7eb2Smrg       s->buffer_offset = s->physical_offset = new_logical;
597627f7eb2Smrg       if (to_read <= s->buffer_size/2)
598627f7eb2Smrg         {
599627f7eb2Smrg           did_read = raw_read (s, s->buffer, s->buffer_size);
600627f7eb2Smrg 	  if (likely (did_read >= 0))
601627f7eb2Smrg 	    {
602627f7eb2Smrg 	      s->physical_offset += did_read;
603627f7eb2Smrg 	      s->active = did_read;
604627f7eb2Smrg 	      did_read = (did_read > to_read) ? to_read : did_read;
605627f7eb2Smrg 	      memcpy (p, s->buffer, did_read);
606627f7eb2Smrg 	    }
607627f7eb2Smrg 	  else
608627f7eb2Smrg 	    return did_read;
609627f7eb2Smrg         }
610627f7eb2Smrg       else
611627f7eb2Smrg         {
612627f7eb2Smrg           did_read = raw_read (s, p, to_read);
613627f7eb2Smrg 	  if (likely (did_read >= 0))
614627f7eb2Smrg 	    {
615627f7eb2Smrg 	      s->physical_offset += did_read;
616627f7eb2Smrg 	      s->active = 0;
617627f7eb2Smrg 	    }
618627f7eb2Smrg 	  else
619627f7eb2Smrg 	    return did_read;
620627f7eb2Smrg         }
621627f7eb2Smrg       nbyte = did_read + nread;
622627f7eb2Smrg     }
623627f7eb2Smrg   s->logical_offset += nbyte;
624627f7eb2Smrg   return nbyte;
625627f7eb2Smrg }
626627f7eb2Smrg 
627627f7eb2Smrg static ssize_t
buf_write(unix_stream * s,const void * buf,ssize_t nbyte)628627f7eb2Smrg buf_write (unix_stream *s, const void *buf, ssize_t nbyte)
629627f7eb2Smrg {
630627f7eb2Smrg   if (nbyte == 0)
631627f7eb2Smrg     return 0;
632627f7eb2Smrg 
633627f7eb2Smrg   if (s->ndirty == 0)
634627f7eb2Smrg     s->buffer_offset = s->logical_offset;
635627f7eb2Smrg 
636627f7eb2Smrg   /* Does the data fit into the buffer?  As a special case, if the
637627f7eb2Smrg      buffer is empty and the request is bigger than s->buffer_size/2,
638627f7eb2Smrg      write directly. This avoids the case where the buffer would have
639627f7eb2Smrg      to be flushed at every write.  */
640627f7eb2Smrg   if (!(s->ndirty == 0 && nbyte > s->buffer_size/2)
641627f7eb2Smrg       && s->logical_offset + nbyte <= s->buffer_offset + s->buffer_size
642627f7eb2Smrg       && s->buffer_offset <= s->logical_offset
643627f7eb2Smrg       && s->buffer_offset + s->ndirty >= s->logical_offset)
644627f7eb2Smrg     {
645627f7eb2Smrg       memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
646627f7eb2Smrg       int nd = (s->logical_offset - s->buffer_offset) + nbyte;
647627f7eb2Smrg       if (nd > s->ndirty)
648627f7eb2Smrg         s->ndirty = nd;
649627f7eb2Smrg     }
650627f7eb2Smrg   else
651627f7eb2Smrg     {
652627f7eb2Smrg       /* Flush, and either fill the buffer with the new data, or if
653627f7eb2Smrg          the request is bigger than the buffer size, write directly
654627f7eb2Smrg          bypassing the buffer.  */
655627f7eb2Smrg       buf_flush (s);
656627f7eb2Smrg       if (nbyte <= s->buffer_size/2)
657627f7eb2Smrg         {
658627f7eb2Smrg           memcpy (s->buffer, buf, nbyte);
659627f7eb2Smrg           s->buffer_offset = s->logical_offset;
660627f7eb2Smrg           s->ndirty += nbyte;
661627f7eb2Smrg         }
662627f7eb2Smrg       else
663627f7eb2Smrg 	{
664627f7eb2Smrg 	  if (s->physical_offset != s->logical_offset)
665627f7eb2Smrg 	    {
666627f7eb2Smrg 	      if (raw_seek (s, s->logical_offset, SEEK_SET) < 0)
667627f7eb2Smrg 		return -1;
668627f7eb2Smrg 	      s->physical_offset = s->logical_offset;
669627f7eb2Smrg 	    }
670627f7eb2Smrg 
671627f7eb2Smrg 	  nbyte = raw_write (s, buf, nbyte);
672627f7eb2Smrg 	  s->physical_offset += nbyte;
673627f7eb2Smrg 	}
674627f7eb2Smrg     }
675627f7eb2Smrg   s->logical_offset += nbyte;
676627f7eb2Smrg   if (s->logical_offset > s->file_length)
677627f7eb2Smrg     s->file_length = s->logical_offset;
678627f7eb2Smrg   return nbyte;
679627f7eb2Smrg }
680627f7eb2Smrg 
681627f7eb2Smrg 
682627f7eb2Smrg /* "Unbuffered" really means I/O statement buffering. For formatted
683627f7eb2Smrg    I/O, the fbuf manages this, and then uses raw I/O. For unformatted
684627f7eb2Smrg    I/O, buffered I/O is used, and the buffer is flushed at the end of
685627f7eb2Smrg    each I/O statement, where this function is called.  Alternatively,
686627f7eb2Smrg    the buffer is flushed at the end of the record if the buffer is
687627f7eb2Smrg    more than half full; this prevents needless seeking back and forth
688627f7eb2Smrg    when writing sequential unformatted.  */
689627f7eb2Smrg 
690627f7eb2Smrg static int
buf_markeor(unix_stream * s)691627f7eb2Smrg buf_markeor (unix_stream *s)
692627f7eb2Smrg {
693627f7eb2Smrg   if (s->unbuffered || s->ndirty >= s->buffer_size / 2)
694627f7eb2Smrg     return buf_flush (s);
695627f7eb2Smrg   return 0;
696627f7eb2Smrg }
697627f7eb2Smrg 
698627f7eb2Smrg static gfc_offset
buf_seek(unix_stream * s,gfc_offset offset,int whence)699627f7eb2Smrg buf_seek (unix_stream *s, gfc_offset offset, int whence)
700627f7eb2Smrg {
701627f7eb2Smrg   switch (whence)
702627f7eb2Smrg     {
703627f7eb2Smrg     case SEEK_SET:
704627f7eb2Smrg       break;
705627f7eb2Smrg     case SEEK_CUR:
706627f7eb2Smrg       offset += s->logical_offset;
707627f7eb2Smrg       break;
708627f7eb2Smrg     case SEEK_END:
709627f7eb2Smrg       offset += s->file_length;
710627f7eb2Smrg       break;
711627f7eb2Smrg     default:
712627f7eb2Smrg       return -1;
713627f7eb2Smrg     }
714627f7eb2Smrg   if (offset < 0)
715627f7eb2Smrg     {
716627f7eb2Smrg       errno = EINVAL;
717627f7eb2Smrg       return -1;
718627f7eb2Smrg     }
719627f7eb2Smrg   s->logical_offset = offset;
720627f7eb2Smrg   return offset;
721627f7eb2Smrg }
722627f7eb2Smrg 
723627f7eb2Smrg static gfc_offset
buf_tell(unix_stream * s)724627f7eb2Smrg buf_tell (unix_stream *s)
725627f7eb2Smrg {
726627f7eb2Smrg   return buf_seek (s, 0, SEEK_CUR);
727627f7eb2Smrg }
728627f7eb2Smrg 
729627f7eb2Smrg static gfc_offset
buf_size(unix_stream * s)730627f7eb2Smrg buf_size (unix_stream *s)
731627f7eb2Smrg {
732627f7eb2Smrg   return s->file_length;
733627f7eb2Smrg }
734627f7eb2Smrg 
735627f7eb2Smrg static int
buf_truncate(unix_stream * s,gfc_offset length)736627f7eb2Smrg buf_truncate (unix_stream *s, gfc_offset length)
737627f7eb2Smrg {
738627f7eb2Smrg   int r;
739627f7eb2Smrg 
740627f7eb2Smrg   if (buf_flush (s) != 0)
741627f7eb2Smrg     return -1;
742627f7eb2Smrg   r = raw_truncate (s, length);
743627f7eb2Smrg   if (r == 0)
744627f7eb2Smrg     s->file_length = length;
745627f7eb2Smrg   return r;
746627f7eb2Smrg }
747627f7eb2Smrg 
748627f7eb2Smrg static int
buf_close(unix_stream * s)749627f7eb2Smrg buf_close (unix_stream *s)
750627f7eb2Smrg {
751627f7eb2Smrg   if (buf_flush (s) != 0)
752627f7eb2Smrg     return -1;
753627f7eb2Smrg   free (s->buffer);
754627f7eb2Smrg   return raw_close (s);
755627f7eb2Smrg }
756627f7eb2Smrg 
757627f7eb2Smrg static const struct stream_vtable buf_vtable = {
758627f7eb2Smrg   .read = (void *) buf_read,
759627f7eb2Smrg   .write = (void *) buf_write,
760627f7eb2Smrg   .seek = (void *) buf_seek,
761627f7eb2Smrg   .tell = (void *) buf_tell,
762627f7eb2Smrg   .size = (void *) buf_size,
763627f7eb2Smrg   .trunc = (void *) buf_truncate,
764627f7eb2Smrg   .close = (void *) buf_close,
765627f7eb2Smrg   .flush = (void *) buf_flush,
766627f7eb2Smrg   .markeor = (void *) buf_markeor
767627f7eb2Smrg };
768627f7eb2Smrg 
769627f7eb2Smrg static int
buf_init(unix_stream * s,bool unformatted)770627f7eb2Smrg buf_init (unix_stream *s, bool unformatted)
771627f7eb2Smrg {
772627f7eb2Smrg   s->st.vptr = &buf_vtable;
773627f7eb2Smrg 
774627f7eb2Smrg   /* Try to guess a good value for the buffer size.  For formatted
775627f7eb2Smrg      I/O, we use so many CPU cycles converting the data that there is
776627f7eb2Smrg      more sense in converving memory and especially cache.  For
777627f7eb2Smrg      unformatted, a bigger block can have a large impact in some
778627f7eb2Smrg      environments.  */
779627f7eb2Smrg 
780627f7eb2Smrg   if (unformatted)
781627f7eb2Smrg     {
782627f7eb2Smrg       if (options.unformatted_buffer_size > 0)
783627f7eb2Smrg 	s->buffer_size = options.unformatted_buffer_size;
784627f7eb2Smrg       else
785627f7eb2Smrg 	s->buffer_size = UNFORMATTED_BUFFER_SIZE_DEFAULT;
786627f7eb2Smrg     }
787627f7eb2Smrg   else
788627f7eb2Smrg     {
789627f7eb2Smrg       if (options.formatted_buffer_size > 0)
790627f7eb2Smrg 	s->buffer_size = options.formatted_buffer_size;
791627f7eb2Smrg       else
792627f7eb2Smrg 	s->buffer_size = FORMATTED_BUFFER_SIZE_DEFAULT;
793627f7eb2Smrg     }
794627f7eb2Smrg 
795627f7eb2Smrg   s->buffer = xmalloc (s->buffer_size);
796627f7eb2Smrg   return 0;
797627f7eb2Smrg }
798627f7eb2Smrg 
799627f7eb2Smrg 
800627f7eb2Smrg /*********************************************************************
801627f7eb2Smrg   memory stream functions - These are used for internal files
802627f7eb2Smrg 
803627f7eb2Smrg   The idea here is that a single stream structure is created and all
804627f7eb2Smrg   requests must be satisfied from it.  The location and size of the
805627f7eb2Smrg   buffer is the character variable supplied to the READ or WRITE
806627f7eb2Smrg   statement.
807627f7eb2Smrg 
808627f7eb2Smrg *********************************************************************/
809627f7eb2Smrg 
810627f7eb2Smrg char *
mem_alloc_r(stream * strm,size_t * len)811627f7eb2Smrg mem_alloc_r (stream *strm, size_t *len)
812627f7eb2Smrg {
813627f7eb2Smrg   unix_stream *s = (unix_stream *) strm;
814627f7eb2Smrg   gfc_offset n;
815627f7eb2Smrg   gfc_offset where = s->logical_offset;
816627f7eb2Smrg 
817627f7eb2Smrg   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
818627f7eb2Smrg     return NULL;
819627f7eb2Smrg 
820627f7eb2Smrg   n = s->buffer_offset + s->active - where;
821627f7eb2Smrg   if ((gfc_offset) *len > n)
822627f7eb2Smrg     *len = n;
823627f7eb2Smrg 
824627f7eb2Smrg   s->logical_offset = where + *len;
825627f7eb2Smrg 
826627f7eb2Smrg   return s->buffer + (where - s->buffer_offset);
827627f7eb2Smrg }
828627f7eb2Smrg 
829627f7eb2Smrg 
830627f7eb2Smrg char *
mem_alloc_r4(stream * strm,size_t * len)831627f7eb2Smrg mem_alloc_r4 (stream *strm, size_t *len)
832627f7eb2Smrg {
833627f7eb2Smrg   unix_stream *s = (unix_stream *) strm;
834627f7eb2Smrg   gfc_offset n;
835627f7eb2Smrg   gfc_offset where = s->logical_offset;
836627f7eb2Smrg 
837627f7eb2Smrg   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
838627f7eb2Smrg     return NULL;
839627f7eb2Smrg 
840627f7eb2Smrg   n = s->buffer_offset + s->active - where;
841627f7eb2Smrg   if ((gfc_offset) *len > n)
842627f7eb2Smrg     *len = n;
843627f7eb2Smrg 
844627f7eb2Smrg   s->logical_offset = where + *len;
845627f7eb2Smrg 
846627f7eb2Smrg   return s->buffer + (where - s->buffer_offset) * 4;
847627f7eb2Smrg }
848627f7eb2Smrg 
849627f7eb2Smrg 
850627f7eb2Smrg char *
mem_alloc_w(stream * strm,size_t * len)851627f7eb2Smrg mem_alloc_w (stream *strm, size_t *len)
852627f7eb2Smrg {
853627f7eb2Smrg   unix_stream *s = (unix_stream *)strm;
854627f7eb2Smrg   gfc_offset m;
855627f7eb2Smrg   gfc_offset where = s->logical_offset;
856627f7eb2Smrg 
857627f7eb2Smrg   m = where + *len;
858627f7eb2Smrg 
859627f7eb2Smrg   if (where < s->buffer_offset)
860627f7eb2Smrg     return NULL;
861627f7eb2Smrg 
862627f7eb2Smrg   if (m > s->file_length)
863627f7eb2Smrg     return NULL;
864627f7eb2Smrg 
865627f7eb2Smrg   s->logical_offset = m;
866627f7eb2Smrg 
867627f7eb2Smrg   return s->buffer + (where - s->buffer_offset);
868627f7eb2Smrg }
869627f7eb2Smrg 
870627f7eb2Smrg 
871627f7eb2Smrg gfc_char4_t *
mem_alloc_w4(stream * strm,size_t * len)872627f7eb2Smrg mem_alloc_w4 (stream *strm, size_t *len)
873627f7eb2Smrg {
874627f7eb2Smrg   unix_stream *s = (unix_stream *)strm;
875627f7eb2Smrg   gfc_offset m;
876627f7eb2Smrg   gfc_offset where = s->logical_offset;
877627f7eb2Smrg   gfc_char4_t *result = (gfc_char4_t *) s->buffer;
878627f7eb2Smrg 
879627f7eb2Smrg   m = where + *len;
880627f7eb2Smrg 
881627f7eb2Smrg   if (where < s->buffer_offset)
882627f7eb2Smrg     return NULL;
883627f7eb2Smrg 
884627f7eb2Smrg   if (m > s->file_length)
885627f7eb2Smrg     return NULL;
886627f7eb2Smrg 
887627f7eb2Smrg   s->logical_offset = m;
888627f7eb2Smrg   return &result[where - s->buffer_offset];
889627f7eb2Smrg }
890627f7eb2Smrg 
891627f7eb2Smrg 
892627f7eb2Smrg /* Stream read function for character(kind=1) internal units.  */
893627f7eb2Smrg 
894627f7eb2Smrg static ssize_t
mem_read(stream * s,void * buf,ssize_t nbytes)895627f7eb2Smrg mem_read (stream *s, void *buf, ssize_t nbytes)
896627f7eb2Smrg {
897627f7eb2Smrg   void *p;
898627f7eb2Smrg   size_t nb = nbytes;
899627f7eb2Smrg 
900627f7eb2Smrg   p = mem_alloc_r (s, &nb);
901627f7eb2Smrg   if (p)
902627f7eb2Smrg     {
903627f7eb2Smrg       memcpy (buf, p, nb);
904627f7eb2Smrg       return (ssize_t) nb;
905627f7eb2Smrg     }
906627f7eb2Smrg   else
907627f7eb2Smrg     return 0;
908627f7eb2Smrg }
909627f7eb2Smrg 
910627f7eb2Smrg 
911627f7eb2Smrg /* Stream read function for chracter(kind=4) internal units.  */
912627f7eb2Smrg 
913627f7eb2Smrg static ssize_t
mem_read4(stream * s,void * buf,ssize_t nbytes)914627f7eb2Smrg mem_read4 (stream *s, void *buf, ssize_t nbytes)
915627f7eb2Smrg {
916627f7eb2Smrg   void *p;
917627f7eb2Smrg   size_t nb = nbytes;
918627f7eb2Smrg 
919627f7eb2Smrg   p = mem_alloc_r4 (s, &nb);
920627f7eb2Smrg   if (p)
921627f7eb2Smrg     {
922627f7eb2Smrg       memcpy (buf, p, nb * 4);
923627f7eb2Smrg       return (ssize_t) nb;
924627f7eb2Smrg     }
925627f7eb2Smrg   else
926627f7eb2Smrg     return 0;
927627f7eb2Smrg }
928627f7eb2Smrg 
929627f7eb2Smrg 
930627f7eb2Smrg /* Stream write function for character(kind=1) internal units.  */
931627f7eb2Smrg 
932627f7eb2Smrg static ssize_t
mem_write(stream * s,const void * buf,ssize_t nbytes)933627f7eb2Smrg mem_write (stream *s, const void *buf, ssize_t nbytes)
934627f7eb2Smrg {
935627f7eb2Smrg   void *p;
936627f7eb2Smrg   size_t nb = nbytes;
937627f7eb2Smrg 
938627f7eb2Smrg   p = mem_alloc_w (s, &nb);
939627f7eb2Smrg   if (p)
940627f7eb2Smrg     {
941627f7eb2Smrg       memcpy (p, buf, nb);
942627f7eb2Smrg       return (ssize_t) nb;
943627f7eb2Smrg     }
944627f7eb2Smrg   else
945627f7eb2Smrg     return 0;
946627f7eb2Smrg }
947627f7eb2Smrg 
948627f7eb2Smrg 
949627f7eb2Smrg /* Stream write function for character(kind=4) internal units.  */
950627f7eb2Smrg 
951627f7eb2Smrg static ssize_t
mem_write4(stream * s,const void * buf,ssize_t nwords)952627f7eb2Smrg mem_write4 (stream *s, const void *buf, ssize_t nwords)
953627f7eb2Smrg {
954627f7eb2Smrg   gfc_char4_t *p;
955627f7eb2Smrg   size_t nw = nwords;
956627f7eb2Smrg 
957627f7eb2Smrg   p = mem_alloc_w4 (s, &nw);
958627f7eb2Smrg   if (p)
959627f7eb2Smrg     {
960627f7eb2Smrg       while (nw--)
961627f7eb2Smrg 	*p++ = (gfc_char4_t) *((char *) buf);
962627f7eb2Smrg       return nwords;
963627f7eb2Smrg     }
964627f7eb2Smrg   else
965627f7eb2Smrg     return 0;
966627f7eb2Smrg }
967627f7eb2Smrg 
968627f7eb2Smrg 
969627f7eb2Smrg static gfc_offset
mem_seek(stream * strm,gfc_offset offset,int whence)970627f7eb2Smrg mem_seek (stream *strm, gfc_offset offset, int whence)
971627f7eb2Smrg {
972627f7eb2Smrg   unix_stream *s = (unix_stream *)strm;
973627f7eb2Smrg   switch (whence)
974627f7eb2Smrg     {
975627f7eb2Smrg     case SEEK_SET:
976627f7eb2Smrg       break;
977627f7eb2Smrg     case SEEK_CUR:
978627f7eb2Smrg       offset += s->logical_offset;
979627f7eb2Smrg       break;
980627f7eb2Smrg     case SEEK_END:
981627f7eb2Smrg       offset += s->file_length;
982627f7eb2Smrg       break;
983627f7eb2Smrg     default:
984627f7eb2Smrg       return -1;
985627f7eb2Smrg     }
986627f7eb2Smrg 
987627f7eb2Smrg   /* Note that for internal array I/O it's actually possible to have a
988627f7eb2Smrg      negative offset, so don't check for that.  */
989627f7eb2Smrg   if (offset > s->file_length)
990627f7eb2Smrg     {
991627f7eb2Smrg       errno = EINVAL;
992627f7eb2Smrg       return -1;
993627f7eb2Smrg     }
994627f7eb2Smrg 
995627f7eb2Smrg   s->logical_offset = offset;
996627f7eb2Smrg 
997627f7eb2Smrg   /* Returning < 0 is the error indicator for sseek(), so return 0 if
998627f7eb2Smrg      offset is negative.  Thus if the return value is 0, the caller
999627f7eb2Smrg      has to use stell() to get the real value of logical_offset.  */
1000627f7eb2Smrg   if (offset >= 0)
1001627f7eb2Smrg     return offset;
1002627f7eb2Smrg   return 0;
1003627f7eb2Smrg }
1004627f7eb2Smrg 
1005627f7eb2Smrg 
1006627f7eb2Smrg static gfc_offset
mem_tell(stream * s)1007627f7eb2Smrg mem_tell (stream *s)
1008627f7eb2Smrg {
1009627f7eb2Smrg   return ((unix_stream *)s)->logical_offset;
1010627f7eb2Smrg }
1011627f7eb2Smrg 
1012627f7eb2Smrg 
1013627f7eb2Smrg static int
mem_truncate(unix_stream * s,gfc_offset length)1014627f7eb2Smrg mem_truncate (unix_stream *s __attribute__ ((unused)),
1015627f7eb2Smrg 	      gfc_offset length __attribute__ ((unused)))
1016627f7eb2Smrg {
1017627f7eb2Smrg   return 0;
1018627f7eb2Smrg }
1019627f7eb2Smrg 
1020627f7eb2Smrg 
1021627f7eb2Smrg static int
mem_flush(unix_stream * s)1022627f7eb2Smrg mem_flush (unix_stream *s __attribute__ ((unused)))
1023627f7eb2Smrg {
1024627f7eb2Smrg   return 0;
1025627f7eb2Smrg }
1026627f7eb2Smrg 
1027627f7eb2Smrg 
1028627f7eb2Smrg static int
mem_close(unix_stream * s)1029627f7eb2Smrg mem_close (unix_stream *s)
1030627f7eb2Smrg {
1031627f7eb2Smrg   if (s)
1032627f7eb2Smrg     free (s);
1033627f7eb2Smrg   return 0;
1034627f7eb2Smrg }
1035627f7eb2Smrg 
1036627f7eb2Smrg static const struct stream_vtable mem_vtable = {
1037627f7eb2Smrg   .read = (void *) mem_read,
1038627f7eb2Smrg   .write = (void *) mem_write,
1039627f7eb2Smrg   .seek = (void *) mem_seek,
1040627f7eb2Smrg   .tell = (void *) mem_tell,
1041627f7eb2Smrg   /* buf_size is not a typo, we just reuse an identical
1042627f7eb2Smrg      implementation.  */
1043627f7eb2Smrg   .size = (void *) buf_size,
1044627f7eb2Smrg   .trunc = (void *) mem_truncate,
1045627f7eb2Smrg   .close = (void *) mem_close,
1046627f7eb2Smrg   .flush = (void *) mem_flush,
1047627f7eb2Smrg   .markeor = (void *) raw_markeor
1048627f7eb2Smrg };
1049627f7eb2Smrg 
1050627f7eb2Smrg static const struct stream_vtable mem4_vtable = {
1051627f7eb2Smrg   .read = (void *) mem_read4,
1052627f7eb2Smrg   .write = (void *) mem_write4,
1053627f7eb2Smrg   .seek = (void *) mem_seek,
1054627f7eb2Smrg   .tell = (void *) mem_tell,
1055627f7eb2Smrg   /* buf_size is not a typo, we just reuse an identical
1056627f7eb2Smrg      implementation.  */
1057627f7eb2Smrg   .size = (void *) buf_size,
1058627f7eb2Smrg   .trunc = (void *) mem_truncate,
1059627f7eb2Smrg   .close = (void *) mem_close,
1060627f7eb2Smrg   .flush = (void *) mem_flush,
1061627f7eb2Smrg   .markeor = (void *) raw_markeor
1062627f7eb2Smrg };
1063627f7eb2Smrg 
1064627f7eb2Smrg /*********************************************************************
1065627f7eb2Smrg   Public functions -- A reimplementation of this module needs to
1066627f7eb2Smrg   define functional equivalents of the following.
1067627f7eb2Smrg *********************************************************************/
1068627f7eb2Smrg 
1069627f7eb2Smrg /* open_internal()-- Returns a stream structure from a character(kind=1)
1070627f7eb2Smrg    internal file */
1071627f7eb2Smrg 
1072627f7eb2Smrg stream *
open_internal(char * base,size_t length,gfc_offset offset)1073627f7eb2Smrg open_internal (char *base, size_t length, gfc_offset offset)
1074627f7eb2Smrg {
1075627f7eb2Smrg   unix_stream *s;
1076627f7eb2Smrg 
1077627f7eb2Smrg   s = xcalloc (1, sizeof (unix_stream));
1078627f7eb2Smrg 
1079627f7eb2Smrg   s->buffer = base;
1080627f7eb2Smrg   s->buffer_offset = offset;
1081627f7eb2Smrg 
1082627f7eb2Smrg   s->active = s->file_length = length;
1083627f7eb2Smrg 
1084627f7eb2Smrg   s->st.vptr = &mem_vtable;
1085627f7eb2Smrg 
1086627f7eb2Smrg   return (stream *) s;
1087627f7eb2Smrg }
1088627f7eb2Smrg 
1089627f7eb2Smrg /* open_internal4()-- Returns a stream structure from a character(kind=4)
1090627f7eb2Smrg    internal file */
1091627f7eb2Smrg 
1092627f7eb2Smrg stream *
open_internal4(char * base,size_t length,gfc_offset offset)1093627f7eb2Smrg open_internal4 (char *base, size_t length, gfc_offset offset)
1094627f7eb2Smrg {
1095627f7eb2Smrg   unix_stream *s;
1096627f7eb2Smrg 
1097627f7eb2Smrg   s = xcalloc (1, sizeof (unix_stream));
1098627f7eb2Smrg 
1099627f7eb2Smrg   s->buffer = base;
1100627f7eb2Smrg   s->buffer_offset = offset;
1101627f7eb2Smrg 
1102627f7eb2Smrg   s->active = s->file_length = length * sizeof (gfc_char4_t);
1103627f7eb2Smrg 
1104627f7eb2Smrg   s->st.vptr = &mem4_vtable;
1105627f7eb2Smrg 
1106627f7eb2Smrg   return (stream *)s;
1107627f7eb2Smrg }
1108627f7eb2Smrg 
1109627f7eb2Smrg 
1110627f7eb2Smrg /* fd_to_stream()-- Given an open file descriptor, build a stream
1111627f7eb2Smrg    around it. */
1112627f7eb2Smrg 
1113627f7eb2Smrg static stream *
fd_to_stream(int fd,bool unformatted)1114627f7eb2Smrg fd_to_stream (int fd, bool unformatted)
1115627f7eb2Smrg {
1116627f7eb2Smrg   struct stat statbuf;
1117627f7eb2Smrg   unix_stream *s;
1118627f7eb2Smrg 
1119627f7eb2Smrg   s = xcalloc (1, sizeof (unix_stream));
1120627f7eb2Smrg 
1121627f7eb2Smrg   s->fd = fd;
1122627f7eb2Smrg 
1123627f7eb2Smrg   /* Get the current length of the file. */
1124627f7eb2Smrg 
1125627f7eb2Smrg   if (TEMP_FAILURE_RETRY (fstat (fd, &statbuf)) == -1)
1126627f7eb2Smrg     {
1127627f7eb2Smrg       s->st_dev = s->st_ino = -1;
1128627f7eb2Smrg       s->file_length = 0;
1129627f7eb2Smrg       if (errno == EBADF)
1130627f7eb2Smrg 	s->fd = -1;
1131627f7eb2Smrg       raw_init (s);
1132627f7eb2Smrg       return (stream *) s;
1133627f7eb2Smrg     }
1134627f7eb2Smrg 
1135627f7eb2Smrg   s->st_dev = statbuf.st_dev;
1136627f7eb2Smrg   s->st_ino = statbuf.st_ino;
1137627f7eb2Smrg   s->file_length = statbuf.st_size;
1138627f7eb2Smrg 
1139627f7eb2Smrg   /* Only use buffered IO for regular files.  */
1140627f7eb2Smrg   if (S_ISREG (statbuf.st_mode)
1141627f7eb2Smrg       && !options.all_unbuffered
1142627f7eb2Smrg       && !(options.unbuffered_preconnected &&
1143627f7eb2Smrg 	   (s->fd == STDIN_FILENO
1144627f7eb2Smrg 	    || s->fd == STDOUT_FILENO
1145627f7eb2Smrg 	    || s->fd == STDERR_FILENO)))
1146627f7eb2Smrg     buf_init (s, unformatted);
1147627f7eb2Smrg   else
1148627f7eb2Smrg     {
1149627f7eb2Smrg       if (unformatted)
1150627f7eb2Smrg 	{
1151627f7eb2Smrg 	  s->unbuffered = true;
1152627f7eb2Smrg 	  buf_init (s, unformatted);
1153627f7eb2Smrg 	}
1154627f7eb2Smrg       else
1155627f7eb2Smrg 	raw_init (s);
1156627f7eb2Smrg     }
1157627f7eb2Smrg 
1158627f7eb2Smrg   return (stream *) s;
1159627f7eb2Smrg }
1160627f7eb2Smrg 
1161627f7eb2Smrg 
1162627f7eb2Smrg /* Given the Fortran unit number, convert it to a C file descriptor.  */
1163627f7eb2Smrg 
1164627f7eb2Smrg int
unit_to_fd(int unit)1165627f7eb2Smrg unit_to_fd (int unit)
1166627f7eb2Smrg {
1167627f7eb2Smrg   gfc_unit *us;
1168627f7eb2Smrg   int fd;
1169627f7eb2Smrg 
1170627f7eb2Smrg   us = find_unit (unit);
1171627f7eb2Smrg   if (us == NULL)
1172627f7eb2Smrg     return -1;
1173627f7eb2Smrg 
1174627f7eb2Smrg   fd = ((unix_stream *) us->s)->fd;
1175627f7eb2Smrg   unlock_unit (us);
1176627f7eb2Smrg   return fd;
1177627f7eb2Smrg }
1178627f7eb2Smrg 
1179627f7eb2Smrg 
1180627f7eb2Smrg /* Set the close-on-exec flag for an existing fd, if the system
1181627f7eb2Smrg    supports such.  */
1182627f7eb2Smrg 
1183627f7eb2Smrg static void __attribute__ ((unused))
set_close_on_exec(int fd)1184627f7eb2Smrg set_close_on_exec (int fd __attribute__ ((unused)))
1185627f7eb2Smrg {
1186627f7eb2Smrg   /* Mingw does not define F_SETFD.  */
1187627f7eb2Smrg #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1188627f7eb2Smrg   if (fd >= 0)
1189627f7eb2Smrg     fcntl(fd, F_SETFD, FD_CLOEXEC);
1190627f7eb2Smrg #endif
1191627f7eb2Smrg }
1192627f7eb2Smrg 
1193627f7eb2Smrg 
1194627f7eb2Smrg /* Helper function for tempfile(). Tries to open a temporary file in
1195627f7eb2Smrg    the directory specified by tempdir. If successful, the file name is
1196627f7eb2Smrg    stored in fname and the descriptor returned. Returns -1 on
1197627f7eb2Smrg    failure.  */
1198627f7eb2Smrg 
1199627f7eb2Smrg static int
tempfile_open(const char * tempdir,char ** fname)1200627f7eb2Smrg tempfile_open (const char *tempdir, char **fname)
1201627f7eb2Smrg {
1202627f7eb2Smrg   int fd;
1203627f7eb2Smrg   const char *slash = "/";
1204627f7eb2Smrg #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1205627f7eb2Smrg   mode_t mode_mask;
1206627f7eb2Smrg #endif
1207627f7eb2Smrg 
1208627f7eb2Smrg   if (!tempdir)
1209627f7eb2Smrg     return -1;
1210627f7eb2Smrg 
1211627f7eb2Smrg   /* Check for the special case that tempdir ends with a slash or
1212627f7eb2Smrg      backslash.  */
1213627f7eb2Smrg   size_t tempdirlen = strlen (tempdir);
1214627f7eb2Smrg   if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1215627f7eb2Smrg #ifdef __MINGW32__
1216627f7eb2Smrg       || tempdir[tempdirlen - 1] == '\\'
1217627f7eb2Smrg #endif
1218627f7eb2Smrg      )
1219627f7eb2Smrg     slash = "";
1220627f7eb2Smrg 
1221627f7eb2Smrg   /* Take care that the template is longer in the mktemp() branch.  */
1222627f7eb2Smrg   char *template = xmalloc (tempdirlen + 23);
1223627f7eb2Smrg 
1224627f7eb2Smrg #ifdef HAVE_MKSTEMP
1225627f7eb2Smrg   snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1226627f7eb2Smrg 	    tempdir, slash);
1227627f7eb2Smrg 
1228627f7eb2Smrg #ifdef HAVE_UMASK
1229627f7eb2Smrg   /* Temporarily set the umask such that the file has 0600 permissions.  */
1230627f7eb2Smrg   mode_mask = umask (S_IXUSR | S_IRWXG | S_IRWXO);
1231627f7eb2Smrg #endif
1232627f7eb2Smrg 
1233627f7eb2Smrg #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1234627f7eb2Smrg   TEMP_FAILURE_RETRY (fd = mkostemp (template, O_CLOEXEC));
1235627f7eb2Smrg #else
1236627f7eb2Smrg   TEMP_FAILURE_RETRY (fd = mkstemp (template));
1237627f7eb2Smrg   set_close_on_exec (fd);
1238627f7eb2Smrg #endif
1239627f7eb2Smrg 
1240627f7eb2Smrg #ifdef HAVE_UMASK
1241627f7eb2Smrg   (void) umask (mode_mask);
1242627f7eb2Smrg #endif
1243627f7eb2Smrg 
1244627f7eb2Smrg #else /* HAVE_MKSTEMP */
1245627f7eb2Smrg   fd = -1;
1246627f7eb2Smrg   int count = 0;
1247627f7eb2Smrg   size_t slashlen = strlen (slash);
1248627f7eb2Smrg   int flags = O_RDWR | O_CREAT | O_EXCL;
1249627f7eb2Smrg #if defined(HAVE_CRLF) && defined(O_BINARY)
1250627f7eb2Smrg   flags |= O_BINARY;
1251627f7eb2Smrg #endif
1252627f7eb2Smrg #ifdef O_CLOEXEC
1253627f7eb2Smrg   flags |= O_CLOEXEC;
1254627f7eb2Smrg #endif
1255627f7eb2Smrg   do
1256627f7eb2Smrg     {
1257627f7eb2Smrg       snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1258627f7eb2Smrg 		tempdir, slash);
1259627f7eb2Smrg       if (count > 0)
1260627f7eb2Smrg 	{
1261627f7eb2Smrg 	  int c = count;
1262627f7eb2Smrg 	  template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1263627f7eb2Smrg 	  c /= 26;
1264627f7eb2Smrg 	  template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1265627f7eb2Smrg 	  c /= 26;
1266627f7eb2Smrg 	  template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1267627f7eb2Smrg 	  if (c >= 26)
1268627f7eb2Smrg 	    break;
1269627f7eb2Smrg 	}
1270627f7eb2Smrg 
1271627f7eb2Smrg       if (!mktemp (template))
1272627f7eb2Smrg       {
1273627f7eb2Smrg 	errno = EEXIST;
1274627f7eb2Smrg 	count++;
1275627f7eb2Smrg 	continue;
1276627f7eb2Smrg       }
1277627f7eb2Smrg 
1278627f7eb2Smrg       TEMP_FAILURE_RETRY (fd = open (template, flags, S_IRUSR | S_IWUSR));
1279627f7eb2Smrg     }
1280627f7eb2Smrg   while (fd == -1 && errno == EEXIST);
1281627f7eb2Smrg #ifndef O_CLOEXEC
1282627f7eb2Smrg   set_close_on_exec (fd);
1283627f7eb2Smrg #endif
1284627f7eb2Smrg #endif /* HAVE_MKSTEMP */
1285627f7eb2Smrg 
1286627f7eb2Smrg   *fname = template;
1287627f7eb2Smrg   return fd;
1288627f7eb2Smrg }
1289627f7eb2Smrg 
1290627f7eb2Smrg 
1291627f7eb2Smrg /* tempfile()-- Generate a temporary filename for a scratch file and
1292627f7eb2Smrg    open it.  mkstemp() opens the file for reading and writing, but the
1293627f7eb2Smrg    library mode prevents anything that is not allowed.  The descriptor
1294627f7eb2Smrg    is returned, which is -1 on error.  The template is pointed to by
1295627f7eb2Smrg    opp->file, which is copied into the unit structure
1296627f7eb2Smrg    and freed later. */
1297627f7eb2Smrg 
1298627f7eb2Smrg static int
tempfile(st_parameter_open * opp)1299627f7eb2Smrg tempfile (st_parameter_open *opp)
1300627f7eb2Smrg {
1301627f7eb2Smrg   const char *tempdir;
1302627f7eb2Smrg   char *fname;
1303627f7eb2Smrg   int fd = -1;
1304627f7eb2Smrg 
1305627f7eb2Smrg   tempdir = secure_getenv ("TMPDIR");
1306627f7eb2Smrg   fd = tempfile_open (tempdir, &fname);
1307627f7eb2Smrg #ifdef __MINGW32__
1308627f7eb2Smrg   if (fd == -1)
1309627f7eb2Smrg     {
1310627f7eb2Smrg       char buffer[MAX_PATH + 1];
1311627f7eb2Smrg       DWORD ret;
1312627f7eb2Smrg       ret = GetTempPath (MAX_PATH, buffer);
1313627f7eb2Smrg       /* If we are not able to get a temp-directory, we use
1314627f7eb2Smrg 	 current directory.  */
1315627f7eb2Smrg       if (ret > MAX_PATH || !ret)
1316627f7eb2Smrg         buffer[0] = 0;
1317627f7eb2Smrg       else
1318627f7eb2Smrg         buffer[ret] = 0;
1319627f7eb2Smrg       tempdir = strdup (buffer);
1320627f7eb2Smrg       fd = tempfile_open (tempdir, &fname);
1321627f7eb2Smrg     }
1322627f7eb2Smrg #elif defined(__CYGWIN__)
1323627f7eb2Smrg   if (fd == -1)
1324627f7eb2Smrg     {
1325627f7eb2Smrg       tempdir = secure_getenv ("TMP");
1326627f7eb2Smrg       fd = tempfile_open (tempdir, &fname);
1327627f7eb2Smrg     }
1328627f7eb2Smrg   if (fd == -1)
1329627f7eb2Smrg     {
1330627f7eb2Smrg       tempdir = secure_getenv ("TEMP");
1331627f7eb2Smrg       fd = tempfile_open (tempdir, &fname);
1332627f7eb2Smrg     }
1333627f7eb2Smrg #endif
1334627f7eb2Smrg   if (fd == -1)
1335627f7eb2Smrg     fd = tempfile_open (P_tmpdir, &fname);
1336627f7eb2Smrg 
1337627f7eb2Smrg   opp->file = fname;
1338627f7eb2Smrg   opp->file_len = strlen (fname);	/* Don't include trailing nul */
1339627f7eb2Smrg 
1340627f7eb2Smrg   return fd;
1341627f7eb2Smrg }
1342627f7eb2Smrg 
1343627f7eb2Smrg 
1344627f7eb2Smrg /* regular_file2()-- Open a regular file.
1345627f7eb2Smrg    Change flags->action if it is ACTION_UNSPECIFIED on entry,
1346627f7eb2Smrg    unless an error occurs.
1347627f7eb2Smrg    Returns the descriptor, which is less than zero on error. */
1348627f7eb2Smrg 
1349627f7eb2Smrg static int
regular_file2(const char * path,st_parameter_open * opp,unit_flags * flags)1350627f7eb2Smrg regular_file2 (const char *path, st_parameter_open *opp, unit_flags *flags)
1351627f7eb2Smrg {
1352627f7eb2Smrg   int mode;
1353627f7eb2Smrg   int rwflag;
1354627f7eb2Smrg   int crflag, crflag2;
1355627f7eb2Smrg   int fd;
1356627f7eb2Smrg 
1357627f7eb2Smrg #ifdef __CYGWIN__
1358627f7eb2Smrg   if (opp->file_len == 7)
1359627f7eb2Smrg     {
1360627f7eb2Smrg       if (strncmp (path, "CONOUT$", 7) == 0
1361627f7eb2Smrg 	  || strncmp (path, "CONERR$", 7) == 0)
1362627f7eb2Smrg 	{
1363627f7eb2Smrg 	  fd = open ("/dev/conout", O_WRONLY);
1364627f7eb2Smrg 	  flags->action = ACTION_WRITE;
1365627f7eb2Smrg 	  return fd;
1366627f7eb2Smrg 	}
1367627f7eb2Smrg     }
1368627f7eb2Smrg 
1369627f7eb2Smrg   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1370627f7eb2Smrg     {
1371627f7eb2Smrg       fd = open ("/dev/conin", O_RDONLY);
1372627f7eb2Smrg       flags->action = ACTION_READ;
1373627f7eb2Smrg       return fd;
1374627f7eb2Smrg     }
1375627f7eb2Smrg #endif
1376627f7eb2Smrg 
1377627f7eb2Smrg 
1378627f7eb2Smrg #ifdef __MINGW32__
1379627f7eb2Smrg   if (opp->file_len == 7)
1380627f7eb2Smrg     {
1381627f7eb2Smrg       if (strncmp (path, "CONOUT$", 7) == 0
1382627f7eb2Smrg 	  || strncmp (path, "CONERR$", 7) == 0)
1383627f7eb2Smrg 	{
1384627f7eb2Smrg 	  fd = open ("CONOUT$", O_WRONLY);
1385627f7eb2Smrg 	  flags->action = ACTION_WRITE;
1386627f7eb2Smrg 	  return fd;
1387627f7eb2Smrg 	}
1388627f7eb2Smrg     }
1389627f7eb2Smrg 
1390627f7eb2Smrg   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1391627f7eb2Smrg     {
1392627f7eb2Smrg       fd = open ("CONIN$", O_RDONLY);
1393627f7eb2Smrg       flags->action = ACTION_READ;
1394627f7eb2Smrg       return fd;
1395627f7eb2Smrg     }
1396627f7eb2Smrg #endif
1397627f7eb2Smrg 
1398627f7eb2Smrg   switch (flags->action)
1399627f7eb2Smrg     {
1400627f7eb2Smrg     case ACTION_READ:
1401627f7eb2Smrg       rwflag = O_RDONLY;
1402627f7eb2Smrg       break;
1403627f7eb2Smrg 
1404627f7eb2Smrg     case ACTION_WRITE:
1405627f7eb2Smrg       rwflag = O_WRONLY;
1406627f7eb2Smrg       break;
1407627f7eb2Smrg 
1408627f7eb2Smrg     case ACTION_READWRITE:
1409627f7eb2Smrg     case ACTION_UNSPECIFIED:
1410627f7eb2Smrg       rwflag = O_RDWR;
1411627f7eb2Smrg       break;
1412627f7eb2Smrg 
1413627f7eb2Smrg     default:
1414627f7eb2Smrg       internal_error (&opp->common, "regular_file(): Bad action");
1415627f7eb2Smrg     }
1416627f7eb2Smrg 
1417627f7eb2Smrg   switch (flags->status)
1418627f7eb2Smrg     {
1419627f7eb2Smrg     case STATUS_NEW:
1420627f7eb2Smrg       crflag = O_CREAT | O_EXCL;
1421627f7eb2Smrg       break;
1422627f7eb2Smrg 
1423627f7eb2Smrg     case STATUS_OLD:		/* open will fail if the file does not exist*/
1424627f7eb2Smrg       crflag = 0;
1425627f7eb2Smrg       break;
1426627f7eb2Smrg 
1427627f7eb2Smrg     case STATUS_UNKNOWN:
1428627f7eb2Smrg       if (rwflag == O_RDONLY)
1429627f7eb2Smrg 	crflag = 0;
1430627f7eb2Smrg       else
1431627f7eb2Smrg 	crflag = O_CREAT;
1432627f7eb2Smrg       break;
1433627f7eb2Smrg 
1434627f7eb2Smrg     case STATUS_REPLACE:
1435627f7eb2Smrg       crflag = O_CREAT | O_TRUNC;
1436627f7eb2Smrg       break;
1437627f7eb2Smrg 
1438627f7eb2Smrg     default:
1439627f7eb2Smrg       /* Note: STATUS_SCRATCH is handled by tempfile () and should
1440627f7eb2Smrg 	 never be seen here.  */
1441627f7eb2Smrg       internal_error (&opp->common, "regular_file(): Bad status");
1442627f7eb2Smrg     }
1443627f7eb2Smrg 
1444627f7eb2Smrg   /* rwflag |= O_LARGEFILE; */
1445627f7eb2Smrg 
1446627f7eb2Smrg #if defined(HAVE_CRLF) && defined(O_BINARY)
1447627f7eb2Smrg   crflag |= O_BINARY;
1448627f7eb2Smrg #endif
1449627f7eb2Smrg 
1450627f7eb2Smrg #ifdef O_CLOEXEC
1451627f7eb2Smrg   crflag |= O_CLOEXEC;
1452627f7eb2Smrg #endif
1453627f7eb2Smrg 
1454627f7eb2Smrg   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1455627f7eb2Smrg   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1456627f7eb2Smrg   if (flags->action != ACTION_UNSPECIFIED)
1457627f7eb2Smrg     return fd;
1458627f7eb2Smrg 
1459627f7eb2Smrg   if (fd >= 0)
1460627f7eb2Smrg     {
1461627f7eb2Smrg       flags->action = ACTION_READWRITE;
1462627f7eb2Smrg       return fd;
1463627f7eb2Smrg     }
1464627f7eb2Smrg   if (errno != EACCES && errno != EPERM && errno != EROFS)
1465627f7eb2Smrg      return fd;
1466627f7eb2Smrg 
1467627f7eb2Smrg   /* retry for read-only access */
1468627f7eb2Smrg   rwflag = O_RDONLY;
1469627f7eb2Smrg   if (flags->status == STATUS_UNKNOWN)
1470627f7eb2Smrg     crflag2 = crflag & ~(O_CREAT);
1471627f7eb2Smrg   else
1472627f7eb2Smrg     crflag2 = crflag;
1473627f7eb2Smrg   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag2, mode));
1474627f7eb2Smrg   if (fd >=0)
1475627f7eb2Smrg     {
1476627f7eb2Smrg       flags->action = ACTION_READ;
1477627f7eb2Smrg       return fd;		/* success */
1478627f7eb2Smrg     }
1479627f7eb2Smrg 
1480627f7eb2Smrg   if (errno != EACCES && errno != EPERM && errno != ENOENT)
1481627f7eb2Smrg     return fd;			/* failure */
1482627f7eb2Smrg 
1483627f7eb2Smrg   /* retry for write-only access */
1484627f7eb2Smrg   rwflag = O_WRONLY;
1485627f7eb2Smrg   TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1486627f7eb2Smrg   if (fd >=0)
1487627f7eb2Smrg     {
1488627f7eb2Smrg       flags->action = ACTION_WRITE;
1489627f7eb2Smrg       return fd;		/* success */
1490627f7eb2Smrg     }
1491627f7eb2Smrg   return fd;			/* failure */
1492627f7eb2Smrg }
1493627f7eb2Smrg 
1494627f7eb2Smrg 
1495627f7eb2Smrg /* Lock the file, if necessary, based on SHARE flags.  */
1496627f7eb2Smrg 
1497627f7eb2Smrg #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1498627f7eb2Smrg static int
open_share(st_parameter_open * opp,int fd,unit_flags * flags)1499627f7eb2Smrg open_share (st_parameter_open *opp, int fd, unit_flags *flags)
1500627f7eb2Smrg {
1501627f7eb2Smrg   int r = 0;
1502627f7eb2Smrg   struct flock f;
1503627f7eb2Smrg   if (fd == STDOUT_FILENO || fd == STDERR_FILENO || fd == STDIN_FILENO)
1504627f7eb2Smrg     return 0;
1505627f7eb2Smrg 
1506627f7eb2Smrg   f.l_start = 0;
1507627f7eb2Smrg   f.l_len = 0;
1508627f7eb2Smrg   f.l_whence = SEEK_SET;
1509627f7eb2Smrg 
1510627f7eb2Smrg   switch (flags->share)
1511627f7eb2Smrg   {
1512627f7eb2Smrg     case SHARE_DENYNONE:
1513627f7eb2Smrg       f.l_type = F_RDLCK;
1514627f7eb2Smrg       r = fcntl (fd, F_SETLK, &f);
1515627f7eb2Smrg       break;
1516627f7eb2Smrg     case SHARE_DENYRW:
1517627f7eb2Smrg       /* Must be writable to hold write lock.  */
1518627f7eb2Smrg       if (flags->action == ACTION_READ)
1519627f7eb2Smrg 	{
1520627f7eb2Smrg 	  generate_error (&opp->common, LIBERROR_BAD_ACTION,
1521627f7eb2Smrg 	      "Cannot set write lock on file opened for READ");
1522627f7eb2Smrg 	  return -1;
1523627f7eb2Smrg 	}
1524627f7eb2Smrg       f.l_type = F_WRLCK;
1525627f7eb2Smrg       r = fcntl (fd, F_SETLK, &f);
1526627f7eb2Smrg       break;
1527627f7eb2Smrg     case SHARE_UNSPECIFIED:
1528627f7eb2Smrg     default:
1529627f7eb2Smrg       break;
1530627f7eb2Smrg   }
1531627f7eb2Smrg 
1532627f7eb2Smrg   return r;
1533627f7eb2Smrg }
1534627f7eb2Smrg #else
1535627f7eb2Smrg static int
open_share(st_parameter_open * opp,int fd,unit_flags * flags)1536627f7eb2Smrg open_share (st_parameter_open *opp __attribute__ ((unused)),
1537627f7eb2Smrg     int fd __attribute__ ((unused)),
1538627f7eb2Smrg     unit_flags *flags __attribute__ ((unused)))
1539627f7eb2Smrg {
1540627f7eb2Smrg   return 0;
1541627f7eb2Smrg }
1542627f7eb2Smrg #endif /* defined(HAVE_FCNTL) ... */
1543627f7eb2Smrg 
1544627f7eb2Smrg 
1545627f7eb2Smrg /* Wrapper around regular_file2, to make sure we free the path after
1546627f7eb2Smrg    we're done.  */
1547627f7eb2Smrg 
1548627f7eb2Smrg static int
regular_file(st_parameter_open * opp,unit_flags * flags)1549627f7eb2Smrg regular_file (st_parameter_open *opp, unit_flags *flags)
1550627f7eb2Smrg {
1551627f7eb2Smrg   char *path = fc_strdup (opp->file, opp->file_len);
1552627f7eb2Smrg   int fd = regular_file2 (path, opp, flags);
1553627f7eb2Smrg   free (path);
1554627f7eb2Smrg   return fd;
1555627f7eb2Smrg }
1556627f7eb2Smrg 
1557627f7eb2Smrg /* open_external()-- Open an external file, unix specific version.
1558627f7eb2Smrg    Change flags->action if it is ACTION_UNSPECIFIED on entry.
1559627f7eb2Smrg    Returns NULL on operating system error. */
1560627f7eb2Smrg 
1561627f7eb2Smrg stream *
open_external(st_parameter_open * opp,unit_flags * flags)1562627f7eb2Smrg open_external (st_parameter_open *opp, unit_flags *flags)
1563627f7eb2Smrg {
1564627f7eb2Smrg   int fd;
1565627f7eb2Smrg 
1566627f7eb2Smrg   if (flags->status == STATUS_SCRATCH)
1567627f7eb2Smrg     {
1568627f7eb2Smrg       fd = tempfile (opp);
1569627f7eb2Smrg       if (flags->action == ACTION_UNSPECIFIED)
1570627f7eb2Smrg 	flags->action = flags->readonly ? ACTION_READ : ACTION_READWRITE;
1571627f7eb2Smrg 
1572627f7eb2Smrg #if HAVE_UNLINK_OPEN_FILE
1573627f7eb2Smrg       /* We can unlink scratch files now and it will go away when closed. */
1574627f7eb2Smrg       if (fd >= 0)
1575627f7eb2Smrg 	unlink (opp->file);
1576627f7eb2Smrg #endif
1577627f7eb2Smrg     }
1578627f7eb2Smrg   else
1579627f7eb2Smrg     {
1580627f7eb2Smrg       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1581627f7eb2Smrg          if it succeeds */
1582627f7eb2Smrg       fd = regular_file (opp, flags);
1583627f7eb2Smrg #ifndef O_CLOEXEC
1584627f7eb2Smrg       set_close_on_exec (fd);
1585627f7eb2Smrg #endif
1586627f7eb2Smrg     }
1587627f7eb2Smrg 
1588627f7eb2Smrg   if (fd < 0)
1589627f7eb2Smrg     return NULL;
1590627f7eb2Smrg   fd = fix_fd (fd);
1591627f7eb2Smrg 
1592627f7eb2Smrg   if (open_share (opp, fd, flags) < 0)
1593627f7eb2Smrg     return NULL;
1594627f7eb2Smrg 
1595627f7eb2Smrg   return fd_to_stream (fd, flags->form == FORM_UNFORMATTED);
1596627f7eb2Smrg }
1597627f7eb2Smrg 
1598627f7eb2Smrg 
1599627f7eb2Smrg /* input_stream()-- Return a stream pointer to the default input stream.
1600627f7eb2Smrg    Called on initialization. */
1601627f7eb2Smrg 
1602627f7eb2Smrg stream *
input_stream(void)1603627f7eb2Smrg input_stream (void)
1604627f7eb2Smrg {
1605627f7eb2Smrg   return fd_to_stream (STDIN_FILENO, false);
1606627f7eb2Smrg }
1607627f7eb2Smrg 
1608627f7eb2Smrg 
1609627f7eb2Smrg /* output_stream()-- Return a stream pointer to the default output stream.
1610627f7eb2Smrg    Called on initialization. */
1611627f7eb2Smrg 
1612627f7eb2Smrg stream *
output_stream(void)1613627f7eb2Smrg output_stream (void)
1614627f7eb2Smrg {
1615627f7eb2Smrg   stream *s;
1616627f7eb2Smrg 
1617627f7eb2Smrg #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1618627f7eb2Smrg   setmode (STDOUT_FILENO, O_BINARY);
1619627f7eb2Smrg #endif
1620627f7eb2Smrg 
1621627f7eb2Smrg   s = fd_to_stream (STDOUT_FILENO, false);
1622627f7eb2Smrg   return s;
1623627f7eb2Smrg }
1624627f7eb2Smrg 
1625627f7eb2Smrg 
1626627f7eb2Smrg /* error_stream()-- Return a stream pointer to the default error stream.
1627627f7eb2Smrg    Called on initialization. */
1628627f7eb2Smrg 
1629627f7eb2Smrg stream *
error_stream(void)1630627f7eb2Smrg error_stream (void)
1631627f7eb2Smrg {
1632627f7eb2Smrg   stream *s;
1633627f7eb2Smrg 
1634627f7eb2Smrg #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1635627f7eb2Smrg   setmode (STDERR_FILENO, O_BINARY);
1636627f7eb2Smrg #endif
1637627f7eb2Smrg 
1638627f7eb2Smrg   s = fd_to_stream (STDERR_FILENO, false);
1639627f7eb2Smrg   return s;
1640627f7eb2Smrg }
1641627f7eb2Smrg 
1642627f7eb2Smrg 
1643627f7eb2Smrg /* compare_file_filename()-- Given an open stream and a fortran string
1644627f7eb2Smrg    that is a filename, figure out if the file is the same as the
1645627f7eb2Smrg    filename. */
1646627f7eb2Smrg 
1647627f7eb2Smrg int
compare_file_filename(gfc_unit * u,const char * name,gfc_charlen_type len)1648627f7eb2Smrg compare_file_filename (gfc_unit *u, const char *name, gfc_charlen_type len)
1649627f7eb2Smrg {
1650627f7eb2Smrg   struct stat st;
1651627f7eb2Smrg   int ret;
1652627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1653627f7eb2Smrg   unix_stream *s;
1654627f7eb2Smrg #else
1655627f7eb2Smrg # ifdef __MINGW32__
1656627f7eb2Smrg   uint64_t id1, id2;
1657627f7eb2Smrg # endif
1658627f7eb2Smrg #endif
1659627f7eb2Smrg 
1660627f7eb2Smrg   char *path = fc_strdup (name, len);
1661627f7eb2Smrg 
1662627f7eb2Smrg   /* If the filename doesn't exist, then there is no match with the
1663627f7eb2Smrg      existing file. */
1664627f7eb2Smrg 
1665627f7eb2Smrg   if (TEMP_FAILURE_RETRY (stat (path, &st)) < 0)
1666627f7eb2Smrg     {
1667627f7eb2Smrg       ret = 0;
1668627f7eb2Smrg       goto done;
1669627f7eb2Smrg     }
1670627f7eb2Smrg 
1671627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1672627f7eb2Smrg   s = (unix_stream *) (u->s);
1673627f7eb2Smrg   ret = (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1674627f7eb2Smrg   goto done;
1675627f7eb2Smrg #else
1676627f7eb2Smrg 
1677627f7eb2Smrg # ifdef __MINGW32__
1678627f7eb2Smrg   /* We try to match files by a unique ID.  On some filesystems (network
1679627f7eb2Smrg      fs and FAT), we can't generate this unique ID, and will simply compare
1680627f7eb2Smrg      filenames.  */
1681627f7eb2Smrg   id1 = id_from_path (path);
1682627f7eb2Smrg   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1683627f7eb2Smrg   if (id1 || id2)
1684627f7eb2Smrg     {
1685627f7eb2Smrg       ret = (id1 == id2);
1686627f7eb2Smrg       goto done;
1687627f7eb2Smrg     }
1688627f7eb2Smrg # endif
1689627f7eb2Smrg   if (u->filename)
1690627f7eb2Smrg     ret = (strcmp(path, u->filename) == 0);
1691627f7eb2Smrg   else
1692627f7eb2Smrg     ret = 0;
1693627f7eb2Smrg #endif
1694627f7eb2Smrg  done:
1695627f7eb2Smrg   free (path);
1696627f7eb2Smrg   return ret;
1697627f7eb2Smrg }
1698627f7eb2Smrg 
1699627f7eb2Smrg 
1700627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1701627f7eb2Smrg # define FIND_FILE0_DECL struct stat *st
1702627f7eb2Smrg # define FIND_FILE0_ARGS st
1703627f7eb2Smrg #else
1704627f7eb2Smrg # define FIND_FILE0_DECL uint64_t id, const char *path
1705627f7eb2Smrg # define FIND_FILE0_ARGS id, path
1706627f7eb2Smrg #endif
1707627f7eb2Smrg 
1708627f7eb2Smrg /* find_file0()-- Recursive work function for find_file() */
1709627f7eb2Smrg 
1710627f7eb2Smrg static gfc_unit *
find_file0(gfc_unit * u,FIND_FILE0_DECL)1711627f7eb2Smrg find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1712627f7eb2Smrg {
1713627f7eb2Smrg   gfc_unit *v;
1714627f7eb2Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1715627f7eb2Smrg   uint64_t id1;
1716627f7eb2Smrg #endif
1717627f7eb2Smrg 
1718627f7eb2Smrg   if (u == NULL)
1719627f7eb2Smrg     return NULL;
1720627f7eb2Smrg 
1721627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1722627f7eb2Smrg   if (u->s != NULL)
1723627f7eb2Smrg     {
1724627f7eb2Smrg       unix_stream *s = (unix_stream *) (u->s);
1725627f7eb2Smrg       if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1726627f7eb2Smrg 	return u;
1727627f7eb2Smrg     }
1728627f7eb2Smrg #else
1729627f7eb2Smrg # ifdef __MINGW32__
1730627f7eb2Smrg   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1731627f7eb2Smrg     {
1732627f7eb2Smrg       if (id == id1)
1733627f7eb2Smrg 	return u;
1734627f7eb2Smrg     }
1735627f7eb2Smrg   else
1736627f7eb2Smrg # endif
1737627f7eb2Smrg     if (u->filename && strcmp (u->filename, path) == 0)
1738627f7eb2Smrg       return u;
1739627f7eb2Smrg #endif
1740627f7eb2Smrg 
1741627f7eb2Smrg   v = find_file0 (u->left, FIND_FILE0_ARGS);
1742627f7eb2Smrg   if (v != NULL)
1743627f7eb2Smrg     return v;
1744627f7eb2Smrg 
1745627f7eb2Smrg   v = find_file0 (u->right, FIND_FILE0_ARGS);
1746627f7eb2Smrg   if (v != NULL)
1747627f7eb2Smrg     return v;
1748627f7eb2Smrg 
1749627f7eb2Smrg   return NULL;
1750627f7eb2Smrg }
1751627f7eb2Smrg 
1752627f7eb2Smrg 
1753627f7eb2Smrg /* find_file()-- Take the current filename and see if there is a unit
1754627f7eb2Smrg    that has the file already open.  Returns a pointer to the unit if so. */
1755627f7eb2Smrg 
1756627f7eb2Smrg gfc_unit *
find_file(const char * file,gfc_charlen_type file_len)1757627f7eb2Smrg find_file (const char *file, gfc_charlen_type file_len)
1758627f7eb2Smrg {
1759627f7eb2Smrg   struct stat st[1];
1760627f7eb2Smrg   gfc_unit *u;
1761627f7eb2Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1762627f7eb2Smrg   uint64_t id = 0ULL;
1763627f7eb2Smrg #endif
1764627f7eb2Smrg 
1765627f7eb2Smrg   char *path = fc_strdup (file, file_len);
1766627f7eb2Smrg 
1767627f7eb2Smrg   if (TEMP_FAILURE_RETRY (stat (path, &st[0])) < 0)
1768627f7eb2Smrg     {
1769627f7eb2Smrg       u = NULL;
1770627f7eb2Smrg       goto done;
1771627f7eb2Smrg     }
1772627f7eb2Smrg 
1773627f7eb2Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1774627f7eb2Smrg   id = id_from_path (path);
1775627f7eb2Smrg #endif
1776627f7eb2Smrg 
1777627f7eb2Smrg   LOCK (&unit_lock);
1778627f7eb2Smrg retry:
1779627f7eb2Smrg   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1780627f7eb2Smrg   if (u != NULL)
1781627f7eb2Smrg     {
1782627f7eb2Smrg       /* Fast path.  */
1783627f7eb2Smrg       if (! __gthread_mutex_trylock (&u->lock))
1784627f7eb2Smrg 	{
1785627f7eb2Smrg 	  /* assert (u->closed == 0); */
1786627f7eb2Smrg 	  UNLOCK (&unit_lock);
1787627f7eb2Smrg 	  goto done;
1788627f7eb2Smrg 	}
1789627f7eb2Smrg 
1790627f7eb2Smrg       inc_waiting_locked (u);
1791627f7eb2Smrg     }
1792627f7eb2Smrg   UNLOCK (&unit_lock);
1793627f7eb2Smrg   if (u != NULL)
1794627f7eb2Smrg     {
1795627f7eb2Smrg       LOCK (&u->lock);
1796627f7eb2Smrg       if (u->closed)
1797627f7eb2Smrg 	{
1798627f7eb2Smrg 	  LOCK (&unit_lock);
1799627f7eb2Smrg 	  UNLOCK (&u->lock);
1800627f7eb2Smrg 	  if (predec_waiting_locked (u) == 0)
1801627f7eb2Smrg 	    free (u);
1802627f7eb2Smrg 	  goto retry;
1803627f7eb2Smrg 	}
1804627f7eb2Smrg 
1805627f7eb2Smrg       dec_waiting_unlocked (u);
1806627f7eb2Smrg     }
1807627f7eb2Smrg  done:
1808627f7eb2Smrg   free (path);
1809627f7eb2Smrg   return u;
1810627f7eb2Smrg }
1811627f7eb2Smrg 
1812627f7eb2Smrg static gfc_unit *
flush_all_units_1(gfc_unit * u,int min_unit)1813627f7eb2Smrg flush_all_units_1 (gfc_unit *u, int min_unit)
1814627f7eb2Smrg {
1815627f7eb2Smrg   while (u != NULL)
1816627f7eb2Smrg     {
1817627f7eb2Smrg       if (u->unit_number > min_unit)
1818627f7eb2Smrg 	{
1819627f7eb2Smrg 	  gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1820627f7eb2Smrg 	  if (r != NULL)
1821627f7eb2Smrg 	    return r;
1822627f7eb2Smrg 	}
1823627f7eb2Smrg       if (u->unit_number >= min_unit)
1824627f7eb2Smrg 	{
1825627f7eb2Smrg 	  if (__gthread_mutex_trylock (&u->lock))
1826627f7eb2Smrg 	    return u;
1827627f7eb2Smrg 	  if (u->s)
1828627f7eb2Smrg 	    sflush (u->s);
1829627f7eb2Smrg 	  UNLOCK (&u->lock);
1830627f7eb2Smrg 	}
1831627f7eb2Smrg       u = u->right;
1832627f7eb2Smrg     }
1833627f7eb2Smrg   return NULL;
1834627f7eb2Smrg }
1835627f7eb2Smrg 
1836627f7eb2Smrg void
flush_all_units(void)1837627f7eb2Smrg flush_all_units (void)
1838627f7eb2Smrg {
1839627f7eb2Smrg   gfc_unit *u;
1840627f7eb2Smrg   int min_unit = 0;
1841627f7eb2Smrg 
1842627f7eb2Smrg   LOCK (&unit_lock);
1843627f7eb2Smrg   do
1844627f7eb2Smrg     {
1845627f7eb2Smrg       u = flush_all_units_1 (unit_root, min_unit);
1846627f7eb2Smrg       if (u != NULL)
1847627f7eb2Smrg 	inc_waiting_locked (u);
1848627f7eb2Smrg       UNLOCK (&unit_lock);
1849627f7eb2Smrg       if (u == NULL)
1850627f7eb2Smrg 	return;
1851627f7eb2Smrg 
1852627f7eb2Smrg       LOCK (&u->lock);
1853627f7eb2Smrg 
1854627f7eb2Smrg       min_unit = u->unit_number + 1;
1855627f7eb2Smrg 
1856627f7eb2Smrg       if (u->closed == 0)
1857627f7eb2Smrg 	{
1858627f7eb2Smrg 	  sflush (u->s);
1859627f7eb2Smrg 	  LOCK (&unit_lock);
1860627f7eb2Smrg 	  UNLOCK (&u->lock);
1861627f7eb2Smrg 	  (void) predec_waiting_locked (u);
1862627f7eb2Smrg 	}
1863627f7eb2Smrg       else
1864627f7eb2Smrg 	{
1865627f7eb2Smrg 	  LOCK (&unit_lock);
1866627f7eb2Smrg 	  UNLOCK (&u->lock);
1867627f7eb2Smrg 	  if (predec_waiting_locked (u) == 0)
1868627f7eb2Smrg 	    free (u);
1869627f7eb2Smrg 	}
1870627f7eb2Smrg     }
1871627f7eb2Smrg   while (1);
1872627f7eb2Smrg }
1873627f7eb2Smrg 
1874627f7eb2Smrg 
1875627f7eb2Smrg /* Unlock the unit if necessary, based on SHARE flags.  */
1876627f7eb2Smrg 
1877627f7eb2Smrg int
close_share(gfc_unit * u)1878627f7eb2Smrg close_share (gfc_unit *u __attribute__ ((unused)))
1879627f7eb2Smrg {
1880627f7eb2Smrg   int r = 0;
1881627f7eb2Smrg #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1882627f7eb2Smrg   unix_stream *s = (unix_stream *) u->s;
1883627f7eb2Smrg   int fd = s->fd;
1884627f7eb2Smrg   struct flock f;
1885627f7eb2Smrg 
1886627f7eb2Smrg   switch (u->flags.share)
1887627f7eb2Smrg   {
1888627f7eb2Smrg     case SHARE_DENYRW:
1889627f7eb2Smrg     case SHARE_DENYNONE:
1890627f7eb2Smrg       if (fd != STDOUT_FILENO && fd != STDERR_FILENO && fd != STDIN_FILENO)
1891627f7eb2Smrg 	{
1892627f7eb2Smrg 	  f.l_start = 0;
1893627f7eb2Smrg 	  f.l_len = 0;
1894627f7eb2Smrg 	  f.l_whence = SEEK_SET;
1895627f7eb2Smrg 	  f.l_type = F_UNLCK;
1896627f7eb2Smrg 	  r = fcntl (fd, F_SETLK, &f);
1897627f7eb2Smrg 	}
1898627f7eb2Smrg       break;
1899627f7eb2Smrg     case SHARE_UNSPECIFIED:
1900627f7eb2Smrg     default:
1901627f7eb2Smrg       break;
1902627f7eb2Smrg   }
1903627f7eb2Smrg 
1904627f7eb2Smrg #endif
1905627f7eb2Smrg   return r;
1906627f7eb2Smrg }
1907627f7eb2Smrg 
1908627f7eb2Smrg 
1909627f7eb2Smrg /* file_exists()-- Returns nonzero if the current filename exists on
1910627f7eb2Smrg    the system */
1911627f7eb2Smrg 
1912627f7eb2Smrg int
file_exists(const char * file,gfc_charlen_type file_len)1913627f7eb2Smrg file_exists (const char *file, gfc_charlen_type file_len)
1914627f7eb2Smrg {
1915627f7eb2Smrg   char *path = fc_strdup (file, file_len);
1916627f7eb2Smrg   int res = !(access (path, F_OK));
1917627f7eb2Smrg   free (path);
1918627f7eb2Smrg   return res;
1919627f7eb2Smrg }
1920627f7eb2Smrg 
1921627f7eb2Smrg 
1922627f7eb2Smrg /* file_size()-- Returns the size of the file.  */
1923627f7eb2Smrg 
1924627f7eb2Smrg GFC_IO_INT
file_size(const char * file,gfc_charlen_type file_len)1925627f7eb2Smrg file_size (const char *file, gfc_charlen_type file_len)
1926627f7eb2Smrg {
1927627f7eb2Smrg   char *path = fc_strdup (file, file_len);
1928627f7eb2Smrg   struct stat statbuf;
1929627f7eb2Smrg   int err;
1930627f7eb2Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1931627f7eb2Smrg   free (path);
1932627f7eb2Smrg   if (err == -1)
1933627f7eb2Smrg     return -1;
1934627f7eb2Smrg   return (GFC_IO_INT) statbuf.st_size;
1935627f7eb2Smrg }
1936627f7eb2Smrg 
1937627f7eb2Smrg static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1938627f7eb2Smrg 
1939627f7eb2Smrg /* inquire_sequential()-- Given a fortran string, determine if the
1940627f7eb2Smrg    file is suitable for sequential access.  Returns a C-style
1941627f7eb2Smrg    string. */
1942627f7eb2Smrg 
1943627f7eb2Smrg const char *
inquire_sequential(const char * string,gfc_charlen_type len)1944627f7eb2Smrg inquire_sequential (const char *string, gfc_charlen_type len)
1945627f7eb2Smrg {
1946627f7eb2Smrg   struct stat statbuf;
1947627f7eb2Smrg 
1948627f7eb2Smrg   if (string == NULL)
1949627f7eb2Smrg     return unknown;
1950627f7eb2Smrg 
1951627f7eb2Smrg   char *path = fc_strdup (string, len);
1952627f7eb2Smrg   int err;
1953627f7eb2Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1954627f7eb2Smrg   free (path);
1955627f7eb2Smrg   if (err == -1)
1956627f7eb2Smrg     return unknown;
1957627f7eb2Smrg 
1958627f7eb2Smrg   if (S_ISREG (statbuf.st_mode) ||
1959627f7eb2Smrg       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1960627f7eb2Smrg     return unknown;
1961627f7eb2Smrg 
1962627f7eb2Smrg   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1963627f7eb2Smrg     return no;
1964627f7eb2Smrg 
1965627f7eb2Smrg   return unknown;
1966627f7eb2Smrg }
1967627f7eb2Smrg 
1968627f7eb2Smrg 
1969627f7eb2Smrg /* inquire_direct()-- Given a fortran string, determine if the file is
1970627f7eb2Smrg    suitable for direct access.  Returns a C-style string. */
1971627f7eb2Smrg 
1972627f7eb2Smrg const char *
inquire_direct(const char * string,gfc_charlen_type len)1973627f7eb2Smrg inquire_direct (const char *string, gfc_charlen_type len)
1974627f7eb2Smrg {
1975627f7eb2Smrg   struct stat statbuf;
1976627f7eb2Smrg 
1977627f7eb2Smrg   if (string == NULL)
1978627f7eb2Smrg     return unknown;
1979627f7eb2Smrg 
1980627f7eb2Smrg   char *path = fc_strdup (string, len);
1981627f7eb2Smrg   int err;
1982627f7eb2Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1983627f7eb2Smrg   free (path);
1984627f7eb2Smrg   if (err == -1)
1985627f7eb2Smrg     return unknown;
1986627f7eb2Smrg 
1987627f7eb2Smrg   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1988627f7eb2Smrg     return unknown;
1989627f7eb2Smrg 
1990627f7eb2Smrg   if (S_ISDIR (statbuf.st_mode) ||
1991627f7eb2Smrg       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1992627f7eb2Smrg     return no;
1993627f7eb2Smrg 
1994627f7eb2Smrg   return unknown;
1995627f7eb2Smrg }
1996627f7eb2Smrg 
1997627f7eb2Smrg 
1998627f7eb2Smrg /* inquire_formatted()-- Given a fortran string, determine if the file
1999627f7eb2Smrg    is suitable for formatted form.  Returns a C-style string. */
2000627f7eb2Smrg 
2001627f7eb2Smrg const char *
inquire_formatted(const char * string,gfc_charlen_type len)2002627f7eb2Smrg inquire_formatted (const char *string, gfc_charlen_type len)
2003627f7eb2Smrg {
2004627f7eb2Smrg   struct stat statbuf;
2005627f7eb2Smrg 
2006627f7eb2Smrg   if (string == NULL)
2007627f7eb2Smrg     return unknown;
2008627f7eb2Smrg 
2009627f7eb2Smrg   char *path = fc_strdup (string, len);
2010627f7eb2Smrg   int err;
2011627f7eb2Smrg   TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
2012627f7eb2Smrg   free (path);
2013627f7eb2Smrg   if (err == -1)
2014627f7eb2Smrg     return unknown;
2015627f7eb2Smrg 
2016627f7eb2Smrg   if (S_ISREG (statbuf.st_mode) ||
2017627f7eb2Smrg       S_ISBLK (statbuf.st_mode) ||
2018627f7eb2Smrg       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
2019627f7eb2Smrg     return unknown;
2020627f7eb2Smrg 
2021627f7eb2Smrg   if (S_ISDIR (statbuf.st_mode))
2022627f7eb2Smrg     return no;
2023627f7eb2Smrg 
2024627f7eb2Smrg   return unknown;
2025627f7eb2Smrg }
2026627f7eb2Smrg 
2027627f7eb2Smrg 
2028627f7eb2Smrg /* inquire_unformatted()-- Given a fortran string, determine if the file
2029627f7eb2Smrg    is suitable for unformatted form.  Returns a C-style string. */
2030627f7eb2Smrg 
2031627f7eb2Smrg const char *
inquire_unformatted(const char * string,gfc_charlen_type len)2032627f7eb2Smrg inquire_unformatted (const char *string, gfc_charlen_type len)
2033627f7eb2Smrg {
2034627f7eb2Smrg   return inquire_formatted (string, len);
2035627f7eb2Smrg }
2036627f7eb2Smrg 
2037627f7eb2Smrg 
2038627f7eb2Smrg /* inquire_access()-- Given a fortran string, determine if the file is
2039627f7eb2Smrg    suitable for access. */
2040627f7eb2Smrg 
2041627f7eb2Smrg static const char *
inquire_access(const char * string,gfc_charlen_type len,int mode)2042627f7eb2Smrg inquire_access (const char *string, gfc_charlen_type len, int mode)
2043627f7eb2Smrg {
2044627f7eb2Smrg   if (string == NULL)
2045627f7eb2Smrg     return no;
2046627f7eb2Smrg   char *path = fc_strdup (string, len);
2047627f7eb2Smrg   int res = access (path, mode);
2048627f7eb2Smrg   free (path);
2049627f7eb2Smrg   if (res == -1)
2050627f7eb2Smrg     return no;
2051627f7eb2Smrg 
2052627f7eb2Smrg   return yes;
2053627f7eb2Smrg }
2054627f7eb2Smrg 
2055627f7eb2Smrg 
2056627f7eb2Smrg /* inquire_read()-- Given a fortran string, determine if the file is
2057627f7eb2Smrg    suitable for READ access. */
2058627f7eb2Smrg 
2059627f7eb2Smrg const char *
inquire_read(const char * string,gfc_charlen_type len)2060627f7eb2Smrg inquire_read (const char *string, gfc_charlen_type len)
2061627f7eb2Smrg {
2062627f7eb2Smrg   return inquire_access (string, len, R_OK);
2063627f7eb2Smrg }
2064627f7eb2Smrg 
2065627f7eb2Smrg 
2066627f7eb2Smrg /* inquire_write()-- Given a fortran string, determine if the file is
2067627f7eb2Smrg    suitable for READ access. */
2068627f7eb2Smrg 
2069627f7eb2Smrg const char *
inquire_write(const char * string,gfc_charlen_type len)2070627f7eb2Smrg inquire_write (const char *string, gfc_charlen_type len)
2071627f7eb2Smrg {
2072627f7eb2Smrg   return inquire_access (string, len, W_OK);
2073627f7eb2Smrg }
2074627f7eb2Smrg 
2075627f7eb2Smrg 
2076627f7eb2Smrg /* inquire_readwrite()-- Given a fortran string, determine if the file is
2077627f7eb2Smrg    suitable for read and write access. */
2078627f7eb2Smrg 
2079627f7eb2Smrg const char *
inquire_readwrite(const char * string,gfc_charlen_type len)2080627f7eb2Smrg inquire_readwrite (const char *string, gfc_charlen_type len)
2081627f7eb2Smrg {
2082627f7eb2Smrg   return inquire_access (string, len, R_OK | W_OK);
2083627f7eb2Smrg }
2084627f7eb2Smrg 
2085627f7eb2Smrg 
2086627f7eb2Smrg int
stream_isatty(stream * s)2087627f7eb2Smrg stream_isatty (stream *s)
2088627f7eb2Smrg {
2089627f7eb2Smrg   return isatty (((unix_stream *) s)->fd);
2090627f7eb2Smrg }
2091627f7eb2Smrg 
2092627f7eb2Smrg int
stream_ttyname(stream * s,char * buf,size_t buflen)2093627f7eb2Smrg stream_ttyname (stream *s  __attribute__ ((unused)),
2094627f7eb2Smrg 		char *buf  __attribute__ ((unused)),
2095627f7eb2Smrg 		size_t buflen  __attribute__ ((unused)))
2096627f7eb2Smrg {
2097627f7eb2Smrg #ifdef HAVE_TTYNAME_R
2098627f7eb2Smrg   return ttyname_r (((unix_stream *)s)->fd, buf, buflen);
2099627f7eb2Smrg #elif defined HAVE_TTYNAME
2100627f7eb2Smrg   char *p;
2101627f7eb2Smrg   size_t plen;
2102627f7eb2Smrg   p = ttyname (((unix_stream *)s)->fd);
2103627f7eb2Smrg   if (!p)
2104627f7eb2Smrg     return errno;
2105627f7eb2Smrg   plen = strlen (p);
2106627f7eb2Smrg   if (buflen < plen)
2107627f7eb2Smrg     plen = buflen;
2108627f7eb2Smrg   memcpy (buf, p, plen);
2109627f7eb2Smrg   return 0;
2110627f7eb2Smrg #else
2111627f7eb2Smrg   return ENOSYS;
2112627f7eb2Smrg #endif
2113627f7eb2Smrg }
2114627f7eb2Smrg 
2115627f7eb2Smrg 
2116627f7eb2Smrg 
2117627f7eb2Smrg 
2118627f7eb2Smrg /* How files are stored:  This is an operating-system specific issue,
2119627f7eb2Smrg    and therefore belongs here.  There are three cases to consider.
2120627f7eb2Smrg 
2121627f7eb2Smrg    Direct Access:
2122627f7eb2Smrg       Records are written as block of bytes corresponding to the record
2123627f7eb2Smrg       length of the file.  This goes for both formatted and unformatted
2124627f7eb2Smrg       records.  Positioning is done explicitly for each data transfer,
2125627f7eb2Smrg       so positioning is not much of an issue.
2126627f7eb2Smrg 
2127627f7eb2Smrg    Sequential Formatted:
2128627f7eb2Smrg       Records are separated by newline characters.  The newline character
2129627f7eb2Smrg       is prohibited from appearing in a string.  If it does, this will be
2130627f7eb2Smrg       messed up on the next read.  End of file is also the end of a record.
2131627f7eb2Smrg 
2132627f7eb2Smrg    Sequential Unformatted:
2133627f7eb2Smrg       In this case, we are merely copying bytes to and from main storage,
2134627f7eb2Smrg       yet we need to keep track of varying record lengths.  We adopt
2135627f7eb2Smrg       the solution used by f2c.  Each record contains a pair of length
2136627f7eb2Smrg       markers:
2137627f7eb2Smrg 
2138627f7eb2Smrg 	Length of record n in bytes
2139627f7eb2Smrg 	Data of record n
2140627f7eb2Smrg 	Length of record n in bytes
2141627f7eb2Smrg 
2142627f7eb2Smrg 	Length of record n+1 in bytes
2143627f7eb2Smrg 	Data of record n+1
2144627f7eb2Smrg 	Length of record n+1 in bytes
2145627f7eb2Smrg 
2146627f7eb2Smrg      The length is stored at the end of a record to allow backspacing to the
2147627f7eb2Smrg      previous record.  Between data transfer statements, the file pointer
2148627f7eb2Smrg      is left pointing to the first length of the current record.
2149627f7eb2Smrg 
2150627f7eb2Smrg      ENDFILE records are never explicitly stored.
2151627f7eb2Smrg 
2152627f7eb2Smrg */
2153