OSDN Git Service

PR 43839
[pf3gnuchains/gcc-fork.git] / libgfortran / io / unix.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4    F2003 I/O support contributed by Jerry DeLisle
5
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
12
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25 <http://www.gnu.org/licenses/>.  */
26
27 /* Unix stream I/O module */
28
29 #include "io.h"
30 #include "unix.h"
31 #include <stdlib.h>
32 #include <limits.h>
33
34 #include <unistd.h>
35 #include <sys/stat.h>
36 #include <fcntl.h>
37 #include <assert.h>
38
39 #include <string.h>
40 #include <errno.h>
41
42
43 /* For mingw, we don't identify files by their inode number, but by a
44    64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
45 #ifdef __MINGW32__
46
47 #define WIN32_LEAN_AND_MEAN
48 #include <windows.h>
49
50 #define lseek _lseeki64
51 #define fstat _fstati64
52 #define stat _stati64
53 typedef struct _stati64 gfstat_t;
54
55 #ifndef HAVE_WORKING_STAT
56 static uint64_t
57 id_from_handle (HANDLE hFile)
58 {
59   BY_HANDLE_FILE_INFORMATION FileInformation;
60
61   if (hFile == INVALID_HANDLE_VALUE)
62       return 0;
63
64   memset (&FileInformation, 0, sizeof(FileInformation));
65   if (!GetFileInformationByHandle (hFile, &FileInformation))
66     return 0;
67
68   return ((uint64_t) FileInformation.nFileIndexLow)
69          | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
70 }
71
72
73 static uint64_t
74 id_from_path (const char *path)
75 {
76   HANDLE hFile;
77   uint64_t res;
78
79   if (!path || !*path || access (path, F_OK))
80     return (uint64_t) -1;
81
82   hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
83                       FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
84                       NULL);
85   res = id_from_handle (hFile);
86   CloseHandle (hFile);
87   return res;
88 }
89
90
91 static uint64_t
92 id_from_fd (const int fd)
93 {
94   return id_from_handle ((HANDLE) _get_osfhandle (fd));
95 }
96
97 #endif
98
99 #else
100 typedef struct stat gfstat_t;
101 #endif
102
103 #ifndef PATH_MAX
104 #define PATH_MAX 1024
105 #endif
106
107 #ifndef PROT_READ
108 #define PROT_READ 1
109 #endif
110
111 #ifndef PROT_WRITE
112 #define PROT_WRITE 2
113 #endif
114
115 /* These flags aren't defined on all targets (mingw32), so provide them
116    here.  */
117 #ifndef S_IRGRP
118 #define S_IRGRP 0
119 #endif
120
121 #ifndef S_IWGRP
122 #define S_IWGRP 0
123 #endif
124
125 #ifndef S_IROTH
126 #define S_IROTH 0
127 #endif
128
129 #ifndef S_IWOTH
130 #define S_IWOTH 0
131 #endif
132
133
134 /* Unix and internal stream I/O module */
135
136 static const int BUFFER_SIZE = 8192;
137
138 typedef struct
139 {
140   stream st;
141
142   gfc_offset buffer_offset;     /* File offset of the start of the buffer */
143   gfc_offset physical_offset;   /* Current physical file offset */
144   gfc_offset logical_offset;    /* Current logical file offset */
145   gfc_offset file_length;       /* Length of the file, -1 if not seekable. */
146
147   char *buffer;                 /* Pointer to the buffer.  */
148   int fd;                       /* The POSIX file descriptor.  */
149
150   int active;                   /* Length of valid bytes in the buffer */
151
152   int prot;
153   int ndirty;                   /* Dirty bytes starting at buffer_offset */
154
155   int special_file;             /* =1 if the fd refers to a special file */
156 }
157 unix_stream;
158
159
160 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
161  * standard descriptors, returning a non-standard descriptor.  If the
162  * user specifies that system errors should go to standard output,
163  * then closes standard output, we don't want the system errors to a
164  * file that has been given file descriptor 1 or 0.  We want to send
165  * the error to the invalid descriptor. */
166
167 static int
168 fix_fd (int fd)
169 {
170 #ifdef HAVE_DUP
171   int input, output, error;
172
173   input = output = error = 0;
174
175   /* Unix allocates the lowest descriptors first, so a loop is not
176      required, but this order is. */
177   if (fd == STDIN_FILENO)
178     {
179       fd = dup (fd);
180       input = 1;
181     }
182   if (fd == STDOUT_FILENO)
183     {
184       fd = dup (fd);
185       output = 1;
186     }
187   if (fd == STDERR_FILENO)
188     {
189       fd = dup (fd);
190       error = 1;
191     }
192
193   if (input)
194     close (STDIN_FILENO);
195   if (output)
196     close (STDOUT_FILENO);
197   if (error)
198     close (STDERR_FILENO);
199 #endif
200
201   return fd;
202 }
203
204
205 /* If the stream corresponds to a preconnected unit, we flush the
206    corresponding C stream.  This is bugware for mixed C-Fortran codes
207    where the C code doesn't flush I/O before returning.  */
208 void
209 flush_if_preconnected (stream * s)
210 {
211   int fd;
212
213   fd = ((unix_stream *) s)->fd;
214   if (fd == STDIN_FILENO)
215     fflush (stdin);
216   else if (fd == STDOUT_FILENO)
217     fflush (stdout);
218   else if (fd == STDERR_FILENO)
219     fflush (stderr);
220 }
221
222
223 /* get_oserror()-- Get the most recent operating system error.  For
224  * unix, this is errno. */
225
226 const char *
227 get_oserror (void)
228 {
229   return strerror (errno);
230 }
231
232
233 /********************************************************************
234 Raw I/O functions (read, write, seek, tell, truncate, close).
235
236 These functions wrap the basic POSIX I/O syscalls. Any deviation in
237 semantics is a bug, except the following: write restarts in case
238 of being interrupted by a signal, and as the first argument the
239 functions take the unix_stream struct rather than an integer file
240 descriptor. Also, for POSIX read() and write() a nbyte argument larger
241 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
242 than size_t as for POSIX read/write.
243 *********************************************************************/
244
245 static int
246 raw_flush (unix_stream * s  __attribute__ ((unused)))
247 {
248   return 0;
249 }
250
251 static ssize_t
252 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
253 {
254   /* For read we can't do I/O in a loop like raw_write does, because
255      that will break applications that wait for interactive I/O.  */
256   return read (s->fd, buf, nbyte);
257 }
258
259 static ssize_t
260 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
261 {
262   ssize_t trans, bytes_left;
263   char *buf_st;
264
265   bytes_left = nbyte;
266   buf_st = (char *) buf;
267
268   /* We must write in a loop since some systems don't restart system
269      calls in case of a signal.  */
270   while (bytes_left > 0)
271     {
272       trans = write (s->fd, buf_st, bytes_left);
273       if (trans < 0)
274         {
275           if (errno == EINTR)
276             continue;
277           else
278             return trans;
279         }
280       buf_st += trans;
281       bytes_left -= trans;
282     }
283
284   return nbyte - bytes_left;
285 }
286
287 static gfc_offset
288 raw_seek (unix_stream * s, gfc_offset offset, int whence)
289 {
290   return lseek (s->fd, offset, whence);
291 }
292
293 static gfc_offset
294 raw_tell (unix_stream * s)
295 {
296   return lseek (s->fd, 0, SEEK_CUR);
297 }
298
299 static int
300 raw_truncate (unix_stream * s, gfc_offset length)
301 {
302 #ifdef __MINGW32__
303   HANDLE h;
304   gfc_offset cur;
305
306   if (isatty (s->fd))
307     {
308       errno = EBADF;
309       return -1;
310     }
311   h = (HANDLE) _get_osfhandle (s->fd);
312   if (h == INVALID_HANDLE_VALUE)
313     {
314       errno = EBADF;
315       return -1;
316     }
317   cur = lseek (s->fd, 0, SEEK_CUR);
318   if (cur == -1)
319     return -1;
320   if (lseek (s->fd, length, SEEK_SET) == -1)
321     goto error;
322   if (!SetEndOfFile (h))
323     {
324       errno = EBADF;
325       goto error;
326     }
327   if (lseek (s->fd, cur, SEEK_SET) == -1)
328     return -1;
329   return 0;
330  error:
331   lseek (s->fd, cur, SEEK_SET);
332   return -1;
333 #elif defined HAVE_FTRUNCATE
334   return ftruncate (s->fd, length);
335 #elif defined HAVE_CHSIZE
336   return chsize (s->fd, length);
337 #else
338   runtime_error ("required ftruncate or chsize support not present");
339   return -1;
340 #endif
341 }
342
343 static int
344 raw_close (unix_stream * s)
345 {
346   int retval;
347   
348   if (s->fd != STDOUT_FILENO
349       && s->fd != STDERR_FILENO
350       && s->fd != STDIN_FILENO)
351     retval = close (s->fd);
352   else
353     retval = 0;
354   free_mem (s);
355   return retval;
356 }
357
358 static int
359 raw_init (unix_stream * s)
360 {
361   s->st.read = (void *) raw_read;
362   s->st.write = (void *) raw_write;
363   s->st.seek = (void *) raw_seek;
364   s->st.tell = (void *) raw_tell;
365   s->st.trunc = (void *) raw_truncate;
366   s->st.close = (void *) raw_close;
367   s->st.flush = (void *) raw_flush;
368
369   s->buffer = NULL;
370   return 0;
371 }
372
373
374 /*********************************************************************
375 Buffered I/O functions. These functions have the same semantics as the
376 raw I/O functions above, except that they are buffered in order to
377 improve performance. The buffer must be flushed when switching from
378 reading to writing and vice versa.
379 *********************************************************************/
380
381 static int
382 buf_flush (unix_stream * s)
383 {
384   int writelen;
385
386   /* Flushing in read mode means discarding read bytes.  */
387   s->active = 0;
388
389   if (s->ndirty == 0)
390     return 0;
391   
392   if (s->file_length != -1 && s->physical_offset != s->buffer_offset
393       && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
394     return -1;
395
396   writelen = raw_write (s, s->buffer, s->ndirty);
397
398   s->physical_offset = s->buffer_offset + writelen;
399
400   /* Don't increment file_length if the file is non-seekable.  */
401   if (s->file_length != -1 && s->physical_offset > s->file_length)
402       s->file_length = s->physical_offset;
403
404   s->ndirty -= writelen;
405   if (s->ndirty != 0)
406     return -1;
407
408   return 0;
409 }
410
411 static ssize_t
412 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
413 {
414   if (s->active == 0)
415     s->buffer_offset = s->logical_offset;
416
417   /* Is the data we want in the buffer?  */
418   if (s->logical_offset + nbyte <= s->buffer_offset + s->active
419       && s->buffer_offset <= s->logical_offset)
420     memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
421   else
422     {
423       /* First copy the active bytes if applicable, then read the rest
424          either directly or filling the buffer.  */
425       char *p;
426       int nread = 0;
427       ssize_t to_read, did_read;
428       gfc_offset new_logical;
429       
430       p = (char *) buf;
431       if (s->logical_offset >= s->buffer_offset 
432           && s->buffer_offset + s->active >= s->logical_offset)
433         {
434           nread = s->active - (s->logical_offset - s->buffer_offset);
435           memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), 
436                   nread);
437           p += nread;
438         }
439       /* At this point we consider all bytes in the buffer discarded.  */
440       to_read = nbyte - nread;
441       new_logical = s->logical_offset + nread;
442       if (s->file_length != -1 && s->physical_offset != new_logical
443           && lseek (s->fd, new_logical, SEEK_SET) < 0)
444         return -1;
445       s->buffer_offset = s->physical_offset = new_logical;
446       if (to_read <= BUFFER_SIZE/2)
447         {
448           did_read = raw_read (s, s->buffer, BUFFER_SIZE);
449           s->physical_offset += did_read;
450           s->active = did_read;
451           did_read = (did_read > to_read) ? to_read : did_read;
452           memcpy (p, s->buffer, did_read);
453         }
454       else
455         {
456           did_read = raw_read (s, p, to_read);
457           s->physical_offset += did_read;
458           s->active = 0;
459         }
460       nbyte = did_read + nread;
461     }
462   s->logical_offset += nbyte;
463   return nbyte;
464 }
465
466 static ssize_t
467 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
468 {
469   if (s->ndirty == 0)
470     s->buffer_offset = s->logical_offset;
471
472   /* Does the data fit into the buffer?  As a special case, if the
473      buffer is empty and the request is bigger than BUFFER_SIZE/2,
474      write directly. This avoids the case where the buffer would have
475      to be flushed at every write.  */
476   if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
477       && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
478       && s->buffer_offset <= s->logical_offset
479       && s->buffer_offset + s->ndirty >= s->logical_offset)
480     {
481       memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
482       int nd = (s->logical_offset - s->buffer_offset) + nbyte;
483       if (nd > s->ndirty)
484         s->ndirty = nd;
485     }
486   else
487     {
488       /* Flush, and either fill the buffer with the new data, or if
489          the request is bigger than the buffer size, write directly
490          bypassing the buffer.  */
491       buf_flush (s);
492       if (nbyte <= BUFFER_SIZE/2)
493         {
494           memcpy (s->buffer, buf, nbyte);
495           s->buffer_offset = s->logical_offset;
496           s->ndirty += nbyte;
497         }
498       else
499         {
500           if (s->file_length != -1 && s->physical_offset != s->logical_offset)
501             {
502               if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
503                 return -1;
504               s->physical_offset = s->logical_offset;
505             }
506
507           nbyte = raw_write (s, buf, nbyte);
508           s->physical_offset += nbyte;
509         }
510     }
511   s->logical_offset += nbyte;
512   /* Don't increment file_length if the file is non-seekable.  */
513   if (s->file_length != -1 && s->logical_offset > s->file_length)
514     s->file_length = s->logical_offset;
515   return nbyte;
516 }
517
518 static gfc_offset
519 buf_seek (unix_stream * s, gfc_offset offset, int whence)
520 {
521   switch (whence)
522     {
523     case SEEK_SET:
524       break;
525     case SEEK_CUR:
526       offset += s->logical_offset;
527       break;
528     case SEEK_END:
529       offset += s->file_length;
530       break;
531     default:
532       return -1;
533     }
534   if (offset < 0)
535     {
536       errno = EINVAL;
537       return -1;
538     }
539   s->logical_offset = offset;
540   return offset;
541 }
542
543 static gfc_offset
544 buf_tell (unix_stream * s)
545 {
546   return s->logical_offset;
547 }
548
549 static int
550 buf_truncate (unix_stream * s, gfc_offset length)
551 {
552   int r;
553
554   if (buf_flush (s) != 0)
555     return -1;
556   r = raw_truncate (s, length);
557   if (r == 0)
558     s->file_length = length;
559   return r;
560 }
561
562 static int
563 buf_close (unix_stream * s)
564 {
565   if (buf_flush (s) != 0)
566     return -1;
567   free_mem (s->buffer);
568   return raw_close (s);
569 }
570
571 static int
572 buf_init (unix_stream * s)
573 {
574   s->st.read = (void *) buf_read;
575   s->st.write = (void *) buf_write;
576   s->st.seek = (void *) buf_seek;
577   s->st.tell = (void *) buf_tell;
578   s->st.trunc = (void *) buf_truncate;
579   s->st.close = (void *) buf_close;
580   s->st.flush = (void *) buf_flush;
581
582   s->buffer = get_mem (BUFFER_SIZE);
583   return 0;
584 }
585
586
587 /*********************************************************************
588   memory stream functions - These are used for internal files
589
590   The idea here is that a single stream structure is created and all
591   requests must be satisfied from it.  The location and size of the
592   buffer is the character variable supplied to the READ or WRITE
593   statement.
594
595 *********************************************************************/
596
597
598 char *
599 mem_alloc_r (stream * strm, int * len)
600 {
601   unix_stream * s = (unix_stream *) strm;
602   gfc_offset n;
603   gfc_offset where = s->logical_offset;
604
605   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
606     return NULL;
607
608   n = s->buffer_offset + s->active - where;
609   if (*len > n)
610     *len = n;
611
612   s->logical_offset = where + *len;
613
614   return s->buffer + (where - s->buffer_offset);
615 }
616
617
618 char *
619 mem_alloc_w (stream * strm, int * len)
620 {
621   unix_stream * s = (unix_stream *) strm;
622   gfc_offset m;
623   gfc_offset where = s->logical_offset;
624
625   m = where + *len;
626
627   if (where < s->buffer_offset)
628     return NULL;
629
630   if (m > s->file_length)
631     return NULL;
632
633   s->logical_offset = m;
634
635   return s->buffer + (where - s->buffer_offset);
636 }
637
638
639 /* Stream read function for internal units.  */
640
641 static ssize_t
642 mem_read (stream * s, void * buf, ssize_t nbytes)
643 {
644   void *p;
645   int nb = nbytes;
646
647   p = mem_alloc_r (s, &nb);
648   if (p)
649     {
650       memcpy (buf, p, nb);
651       return (ssize_t) nb;
652     }
653   else
654     return 0;
655 }
656
657
658 /* Stream write function for internal units. This is not actually used
659    at the moment, as all internal IO is formatted and the formatted IO
660    routines use mem_alloc_w_at.  */
661
662 static ssize_t
663 mem_write (stream * s, const void * buf, ssize_t nbytes)
664 {
665   void *p;
666   int nb = nbytes;
667
668   p = mem_alloc_w (s, &nb);
669   if (p)
670     {
671       memcpy (p, buf, nb);
672       return (ssize_t) nb;
673     }
674   else
675     return 0;
676 }
677
678
679 static gfc_offset
680 mem_seek (stream * strm, gfc_offset offset, int whence)
681 {
682   unix_stream * s = (unix_stream *) strm;
683   switch (whence)
684     {
685     case SEEK_SET:
686       break;
687     case SEEK_CUR:
688       offset += s->logical_offset;
689       break;
690     case SEEK_END:
691       offset += s->file_length;
692       break;
693     default:
694       return -1;
695     }
696
697   /* Note that for internal array I/O it's actually possible to have a
698      negative offset, so don't check for that.  */
699   if (offset > s->file_length)
700     {
701       errno = EINVAL;
702       return -1;
703     }
704
705   s->logical_offset = offset;
706
707   /* Returning < 0 is the error indicator for sseek(), so return 0 if
708      offset is negative.  Thus if the return value is 0, the caller
709      has to use stell() to get the real value of logical_offset.  */
710   if (offset >= 0)
711     return offset;
712   return 0;
713 }
714
715
716 static gfc_offset
717 mem_tell (stream * s)
718 {
719   return ((unix_stream *)s)->logical_offset;
720 }
721
722
723 static int
724 mem_truncate (unix_stream * s __attribute__ ((unused)), 
725               gfc_offset length __attribute__ ((unused)))
726 {
727   return 0;
728 }
729
730
731 static int
732 mem_flush (unix_stream * s __attribute__ ((unused)))
733 {
734   return 0;
735 }
736
737
738 static int
739 mem_close (unix_stream * s)
740 {
741   if (s != NULL)
742     free_mem (s);
743
744   return 0;
745 }
746
747
748 /*********************************************************************
749   Public functions -- A reimplementation of this module needs to
750   define functional equivalents of the following.
751 *********************************************************************/
752
753 /* empty_internal_buffer()-- Zero the buffer of Internal file */
754
755 void
756 empty_internal_buffer(stream *strm)
757 {
758   unix_stream * s = (unix_stream *) strm;
759   memset(s->buffer, ' ', s->file_length);
760 }
761
762 /* open_internal()-- Returns a stream structure from an internal file */
763
764 stream *
765 open_internal (char *base, int length, gfc_offset offset)
766 {
767   unix_stream *s;
768
769   s = get_mem (sizeof (unix_stream));
770   memset (s, '\0', sizeof (unix_stream));
771
772   s->buffer = base;
773   s->buffer_offset = offset;
774
775   s->logical_offset = 0;
776   s->active = s->file_length = length;
777
778   s->st.close = (void *) mem_close;
779   s->st.seek = (void *) mem_seek;
780   s->st.tell = (void *) mem_tell;
781   s->st.trunc = (void *) mem_truncate;
782   s->st.read = (void *) mem_read;
783   s->st.write = (void *) mem_write;
784   s->st.flush = (void *) mem_flush;
785
786   return (stream *) s;
787 }
788
789
790 /* fd_to_stream()-- Given an open file descriptor, build a stream
791  * around it. */
792
793 static stream *
794 fd_to_stream (int fd, int prot)
795 {
796   gfstat_t statbuf;
797   unix_stream *s;
798
799   s = get_mem (sizeof (unix_stream));
800   memset (s, '\0', sizeof (unix_stream));
801
802   s->fd = fd;
803   s->buffer_offset = 0;
804   s->physical_offset = 0;
805   s->logical_offset = 0;
806   s->prot = prot;
807
808   /* Get the current length of the file. */
809
810   fstat (fd, &statbuf);
811
812   if (lseek (fd, 0, SEEK_CUR) == (gfc_offset) -1)
813     s->file_length = -1;
814   else
815     s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
816
817   s->special_file = !S_ISREG (statbuf.st_mode);
818
819   if (isatty (s->fd) || options.all_unbuffered
820       ||(options.unbuffered_preconnected && 
821          (s->fd == STDIN_FILENO 
822           || s->fd == STDOUT_FILENO 
823           || s->fd == STDERR_FILENO)))
824     raw_init (s);
825   else
826     buf_init (s);
827
828   return (stream *) s;
829 }
830
831
832 /* Given the Fortran unit number, convert it to a C file descriptor.  */
833
834 int
835 unit_to_fd (int unit)
836 {
837   gfc_unit *us;
838   int fd;
839
840   us = find_unit (unit);
841   if (us == NULL)
842     return -1;
843
844   fd = ((unix_stream *) us->s)->fd;
845   unlock_unit (us);
846   return fd;
847 }
848
849
850 /* unpack_filename()-- Given a fortran string and a pointer to a
851  * buffer that is PATH_MAX characters, convert the fortran string to a
852  * C string in the buffer.  Returns nonzero if this is not possible.  */
853
854 int
855 unpack_filename (char *cstring, const char *fstring, int len)
856 {
857   len = fstrlen (fstring, len);
858   if (len >= PATH_MAX)
859     return 1;
860
861   memmove (cstring, fstring, len);
862   cstring[len] = '\0';
863
864   return 0;
865 }
866
867
868 /* tempfile()-- Generate a temporary filename for a scratch file and
869  * open it.  mkstemp() opens the file for reading and writing, but the
870  * library mode prevents anything that is not allowed.  The descriptor
871  * is returned, which is -1 on error.  The template is pointed to by 
872  * opp->file, which is copied into the unit structure
873  * and freed later. */
874
875 static int
876 tempfile (st_parameter_open *opp)
877 {
878   const char *tempdir;
879   char *template;
880   const char *slash = "/";
881   int fd;
882
883   tempdir = getenv ("GFORTRAN_TMPDIR");
884 #ifdef __MINGW32__
885   if (tempdir == NULL)
886     {
887       char buffer[MAX_PATH + 1];
888       DWORD ret;
889       ret = GetTempPath (MAX_PATH, buffer);
890       /* If we are not able to get a temp-directory, we use
891          current directory.  */
892       if (ret > MAX_PATH || !ret)
893         buffer[0] = 0;
894       else
895         buffer[ret] = 0;
896       tempdir = strdup (buffer);
897     }
898 #else
899   if (tempdir == NULL)
900     tempdir = getenv ("TMP");
901   if (tempdir == NULL)
902     tempdir = getenv ("TEMP");
903   if (tempdir == NULL)
904     tempdir = DEFAULT_TEMPDIR;
905 #endif
906   /* Check for special case that tempdir contains slash
907      or backslash at end.  */
908   if (*tempdir == 0 || tempdir[strlen (tempdir) - 1] == '/'
909 #ifdef __MINGW32__
910       || tempdir[strlen (tempdir) - 1] == '\\'
911 #endif
912      )
913     slash = "";
914
915   template = get_mem (strlen (tempdir) + 20);
916
917 #ifdef HAVE_MKSTEMP
918   sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
919
920   fd = mkstemp (template);
921
922 #else /* HAVE_MKSTEMP */
923   fd = -1;
924   do
925     {
926       sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
927       if (!mktemp (template))
928         break;
929 #if defined(HAVE_CRLF) && defined(O_BINARY)
930       fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
931                  S_IREAD | S_IWRITE);
932 #else
933       fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
934 #endif
935     }
936   while (fd == -1 && errno == EEXIST);
937 #endif /* HAVE_MKSTEMP */
938
939   if (fd < 0)
940     free_mem (template);
941   else
942     {
943       opp->file = template;
944       opp->file_len = strlen (template);        /* Don't include trailing nul */
945     }
946
947   return fd;
948 }
949
950
951 /* regular_file()-- Open a regular file.
952  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
953  * unless an error occurs.
954  * Returns the descriptor, which is less than zero on error. */
955
956 static int
957 regular_file (st_parameter_open *opp, unit_flags *flags)
958 {
959   char path[PATH_MAX + 1];
960   int mode;
961   int rwflag;
962   int crflag;
963   int fd;
964
965   if (unpack_filename (path, opp->file, opp->file_len))
966     {
967       errno = ENOENT;           /* Fake an OS error */
968       return -1;
969     }
970
971 #ifdef __CYGWIN__
972   if (opp->file_len == 7)
973     {
974       if (strncmp (path, "CONOUT$", 7) == 0
975           || strncmp (path, "CONERR$", 7) == 0)
976         {
977           fd = open ("/dev/conout", O_WRONLY);
978           flags->action = ACTION_WRITE;
979           return fd;
980         }
981     }
982
983   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
984     {
985       fd = open ("/dev/conin", O_RDONLY);
986       flags->action = ACTION_READ;
987       return fd;
988     }
989 #endif
990
991
992 #ifdef __MINGW32__
993   if (opp->file_len == 7)
994     {
995       if (strncmp (path, "CONOUT$", 7) == 0
996           || strncmp (path, "CONERR$", 7) == 0)
997         {
998           fd = open ("CONOUT$", O_WRONLY);
999           flags->action = ACTION_WRITE;
1000           return fd;
1001         }
1002     }
1003
1004   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1005     {
1006       fd = open ("CONIN$", O_RDONLY);
1007       flags->action = ACTION_READ;
1008       return fd;
1009     }
1010 #endif
1011
1012   rwflag = 0;
1013
1014   switch (flags->action)
1015     {
1016     case ACTION_READ:
1017       rwflag = O_RDONLY;
1018       break;
1019
1020     case ACTION_WRITE:
1021       rwflag = O_WRONLY;
1022       break;
1023
1024     case ACTION_READWRITE:
1025     case ACTION_UNSPECIFIED:
1026       rwflag = O_RDWR;
1027       break;
1028
1029     default:
1030       internal_error (&opp->common, "regular_file(): Bad action");
1031     }
1032
1033   switch (flags->status)
1034     {
1035     case STATUS_NEW:
1036       crflag = O_CREAT | O_EXCL;
1037       break;
1038
1039     case STATUS_OLD:            /* open will fail if the file does not exist*/
1040       crflag = 0;
1041       break;
1042
1043     case STATUS_UNKNOWN:
1044     case STATUS_SCRATCH:
1045       crflag = O_CREAT;
1046       break;
1047
1048     case STATUS_REPLACE:
1049       crflag = O_CREAT | O_TRUNC;
1050       break;
1051
1052     default:
1053       internal_error (&opp->common, "regular_file(): Bad status");
1054     }
1055
1056   /* rwflag |= O_LARGEFILE; */
1057
1058 #if defined(HAVE_CRLF) && defined(O_BINARY)
1059   crflag |= O_BINARY;
1060 #endif
1061
1062   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1063   fd = open (path, rwflag | crflag, mode);
1064   if (flags->action != ACTION_UNSPECIFIED)
1065     return fd;
1066
1067   if (fd >= 0)
1068     {
1069       flags->action = ACTION_READWRITE;
1070       return fd;
1071     }
1072   if (errno != EACCES && errno != EROFS)
1073      return fd;
1074
1075   /* retry for read-only access */
1076   rwflag = O_RDONLY;
1077   fd = open (path, rwflag | crflag, mode);
1078   if (fd >=0)
1079     {
1080       flags->action = ACTION_READ;
1081       return fd;                /* success */
1082     }
1083   
1084   if (errno != EACCES)
1085     return fd;                  /* failure */
1086
1087   /* retry for write-only access */
1088   rwflag = O_WRONLY;
1089   fd = open (path, rwflag | crflag, mode);
1090   if (fd >=0)
1091     {
1092       flags->action = ACTION_WRITE;
1093       return fd;                /* success */
1094     }
1095   return fd;                    /* failure */
1096 }
1097
1098
1099 /* open_external()-- Open an external file, unix specific version.
1100  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1101  * Returns NULL on operating system error. */
1102
1103 stream *
1104 open_external (st_parameter_open *opp, unit_flags *flags)
1105 {
1106   int fd, prot;
1107
1108   if (flags->status == STATUS_SCRATCH)
1109     {
1110       fd = tempfile (opp);
1111       if (flags->action == ACTION_UNSPECIFIED)
1112         flags->action = ACTION_READWRITE;
1113
1114 #if HAVE_UNLINK_OPEN_FILE
1115       /* We can unlink scratch files now and it will go away when closed. */
1116       if (fd >= 0)
1117         unlink (opp->file);
1118 #endif
1119     }
1120   else
1121     {
1122       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1123        * if it succeeds */
1124       fd = regular_file (opp, flags);
1125     }
1126
1127   if (fd < 0)
1128     return NULL;
1129   fd = fix_fd (fd);
1130
1131   switch (flags->action)
1132     {
1133     case ACTION_READ:
1134       prot = PROT_READ;
1135       break;
1136
1137     case ACTION_WRITE:
1138       prot = PROT_WRITE;
1139       break;
1140
1141     case ACTION_READWRITE:
1142       prot = PROT_READ | PROT_WRITE;
1143       break;
1144
1145     default:
1146       internal_error (&opp->common, "open_external(): Bad action");
1147     }
1148
1149   return fd_to_stream (fd, prot);
1150 }
1151
1152
1153 /* input_stream()-- Return a stream pointer to the default input stream.
1154  * Called on initialization. */
1155
1156 stream *
1157 input_stream (void)
1158 {
1159   return fd_to_stream (STDIN_FILENO, PROT_READ);
1160 }
1161
1162
1163 /* output_stream()-- Return a stream pointer to the default output stream.
1164  * Called on initialization. */
1165
1166 stream *
1167 output_stream (void)
1168 {
1169   stream * s;
1170
1171 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1172   setmode (STDOUT_FILENO, O_BINARY);
1173 #endif
1174
1175   s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1176   return s;
1177 }
1178
1179
1180 /* error_stream()-- Return a stream pointer to the default error stream.
1181  * Called on initialization. */
1182
1183 stream *
1184 error_stream (void)
1185 {
1186   stream * s;
1187
1188 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1189   setmode (STDERR_FILENO, O_BINARY);
1190 #endif
1191
1192   s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1193   return s;
1194 }
1195
1196
1197 /* st_vprintf()-- vprintf function for error output.  To avoid buffer
1198    overruns, we limit the length of the buffer to ST_VPRINTF_SIZE.  2k
1199    is big enough to completely fill a 80x25 terminal, so it shuld be
1200    OK.  We use a direct write() because it is simpler and least likely
1201    to be clobbered by memory corruption.  Writing an error message
1202    longer than that is an error.  */
1203
1204 #define ST_VPRINTF_SIZE 2048
1205
1206 int
1207 st_vprintf (const char *format, va_list ap)
1208 {
1209   static char buffer[ST_VPRINTF_SIZE];
1210   int written;
1211   int fd;
1212
1213   fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1214 #ifdef HAVE_VSNPRINTF
1215   written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1216 #else
1217   written = vsprintf(buffer, format, ap);
1218
1219   if (written >= ST_VPRINTF_SIZE-1)
1220     {
1221       /* The error message was longer than our buffer.  Ouch.  Because
1222          we may have messed up things badly, report the error and
1223          quit.  */
1224 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1225       write (fd, buffer, ST_VPRINTF_SIZE-1);
1226       write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1227       sys_exit(2);
1228 #undef ERROR_MESSAGE
1229
1230     }
1231 #endif
1232
1233   written = write (fd, buffer, written);
1234   return written;
1235 }
1236
1237 /* st_printf()-- printf() function for error output.  This just calls
1238    st_vprintf() to do the actual work.  */
1239
1240 int
1241 st_printf (const char *format, ...)
1242 {
1243   int written;
1244   va_list ap;
1245   va_start (ap, format);
1246   written = st_vprintf(format, ap);
1247   va_end (ap);
1248   return written;
1249 }
1250
1251
1252 /* compare_file_filename()-- Given an open stream and a fortran string
1253  * that is a filename, figure out if the file is the same as the
1254  * filename. */
1255
1256 int
1257 compare_file_filename (gfc_unit *u, const char *name, int len)
1258 {
1259   char path[PATH_MAX + 1];
1260   gfstat_t st1;
1261 #ifdef HAVE_WORKING_STAT
1262   gfstat_t st2;
1263 #else
1264 # ifdef __MINGW32__
1265   uint64_t id1, id2;
1266 # endif
1267 #endif
1268
1269   if (unpack_filename (path, name, len))
1270     return 0;                   /* Can't be the same */
1271
1272   /* If the filename doesn't exist, then there is no match with the
1273    * existing file. */
1274
1275   if (stat (path, &st1) < 0)
1276     return 0;
1277
1278 #ifdef HAVE_WORKING_STAT
1279   fstat (((unix_stream *) (u->s))->fd, &st2);
1280   return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1281 #else
1282
1283 # ifdef __MINGW32__
1284   /* We try to match files by a unique ID.  On some filesystems (network
1285      fs and FAT), we can't generate this unique ID, and will simply compare
1286      filenames.  */
1287   id1 = id_from_path (path);
1288   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1289   if (id1 || id2)
1290     return (id1 == id2);
1291 # endif
1292
1293   if (len != u->file_len)
1294     return 0;
1295   return (memcmp(path, u->file, len) == 0);
1296 #endif
1297 }
1298
1299
1300 #ifdef HAVE_WORKING_STAT
1301 # define FIND_FILE0_DECL gfstat_t *st
1302 # define FIND_FILE0_ARGS st
1303 #else
1304 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1305 # define FIND_FILE0_ARGS id, file, file_len
1306 #endif
1307
1308 /* find_file0()-- Recursive work function for find_file() */
1309
1310 static gfc_unit *
1311 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1312 {
1313   gfc_unit *v;
1314 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1315   uint64_t id1;
1316 #endif
1317
1318   if (u == NULL)
1319     return NULL;
1320
1321 #ifdef HAVE_WORKING_STAT
1322   if (u->s != NULL
1323       && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1324       st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1325     return u;
1326 #else
1327 # ifdef __MINGW32__ 
1328   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1329     {
1330       if (id == id1)
1331         return u;
1332     }
1333   else
1334 # endif
1335     if (compare_string (u->file_len, u->file, file_len, file) == 0)
1336       return u;
1337 #endif
1338
1339   v = find_file0 (u->left, FIND_FILE0_ARGS);
1340   if (v != NULL)
1341     return v;
1342
1343   v = find_file0 (u->right, FIND_FILE0_ARGS);
1344   if (v != NULL)
1345     return v;
1346
1347   return NULL;
1348 }
1349
1350
1351 /* find_file()-- Take the current filename and see if there is a unit
1352  * that has the file already open.  Returns a pointer to the unit if so. */
1353
1354 gfc_unit *
1355 find_file (const char *file, gfc_charlen_type file_len)
1356 {
1357   char path[PATH_MAX + 1];
1358   gfstat_t st[2];
1359   gfc_unit *u;
1360 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1361   uint64_t id = 0ULL;
1362 #endif
1363
1364   if (unpack_filename (path, file, file_len))
1365     return NULL;
1366
1367   if (stat (path, &st[0]) < 0)
1368     return NULL;
1369
1370 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1371   id = id_from_path (path);
1372 #endif
1373
1374   __gthread_mutex_lock (&unit_lock);
1375 retry:
1376   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1377   if (u != NULL)
1378     {
1379       /* Fast path.  */
1380       if (! __gthread_mutex_trylock (&u->lock))
1381         {
1382           /* assert (u->closed == 0); */
1383           __gthread_mutex_unlock (&unit_lock);
1384           return u;
1385         }
1386
1387       inc_waiting_locked (u);
1388     }
1389   __gthread_mutex_unlock (&unit_lock);
1390   if (u != NULL)
1391     {
1392       __gthread_mutex_lock (&u->lock);
1393       if (u->closed)
1394         {
1395           __gthread_mutex_lock (&unit_lock);
1396           __gthread_mutex_unlock (&u->lock);
1397           if (predec_waiting_locked (u) == 0)
1398             free_mem (u);
1399           goto retry;
1400         }
1401
1402       dec_waiting_unlocked (u);
1403     }
1404   return u;
1405 }
1406
1407 static gfc_unit *
1408 flush_all_units_1 (gfc_unit *u, int min_unit)
1409 {
1410   while (u != NULL)
1411     {
1412       if (u->unit_number > min_unit)
1413         {
1414           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1415           if (r != NULL)
1416             return r;
1417         }
1418       if (u->unit_number >= min_unit)
1419         {
1420           if (__gthread_mutex_trylock (&u->lock))
1421             return u;
1422           if (u->s)
1423             sflush (u->s);
1424           __gthread_mutex_unlock (&u->lock);
1425         }
1426       u = u->right;
1427     }
1428   return NULL;
1429 }
1430
1431 void
1432 flush_all_units (void)
1433 {
1434   gfc_unit *u;
1435   int min_unit = 0;
1436
1437   __gthread_mutex_lock (&unit_lock);
1438   do
1439     {
1440       u = flush_all_units_1 (unit_root, min_unit);
1441       if (u != NULL)
1442         inc_waiting_locked (u);
1443       __gthread_mutex_unlock (&unit_lock);
1444       if (u == NULL)
1445         return;
1446
1447       __gthread_mutex_lock (&u->lock);
1448
1449       min_unit = u->unit_number + 1;
1450
1451       if (u->closed == 0)
1452         {
1453           sflush (u->s);
1454           __gthread_mutex_lock (&unit_lock);
1455           __gthread_mutex_unlock (&u->lock);
1456           (void) predec_waiting_locked (u);
1457         }
1458       else
1459         {
1460           __gthread_mutex_lock (&unit_lock);
1461           __gthread_mutex_unlock (&u->lock);
1462           if (predec_waiting_locked (u) == 0)
1463             free_mem (u);
1464         }
1465     }
1466   while (1);
1467 }
1468
1469
1470 /* delete_file()-- Given a unit structure, delete the file associated
1471  * with the unit.  Returns nonzero if something went wrong. */
1472
1473 int
1474 delete_file (gfc_unit * u)
1475 {
1476   char path[PATH_MAX + 1];
1477
1478   if (unpack_filename (path, u->file, u->file_len))
1479     {                           /* Shouldn't be possible */
1480       errno = ENOENT;
1481       return 1;
1482     }
1483
1484   return unlink (path);
1485 }
1486
1487
1488 /* file_exists()-- Returns nonzero if the current filename exists on
1489  * the system */
1490
1491 int
1492 file_exists (const char *file, gfc_charlen_type file_len)
1493 {
1494   char path[PATH_MAX + 1];
1495   gfstat_t statbuf;
1496
1497   if (unpack_filename (path, file, file_len))
1498     return 0;
1499
1500   if (stat (path, &statbuf) < 0)
1501     return 0;
1502
1503   return 1;
1504 }
1505
1506
1507 /* file_size()-- Returns the size of the file.  */
1508
1509 GFC_IO_INT
1510 file_size (const char *file, gfc_charlen_type file_len)
1511 {
1512   char path[PATH_MAX + 1];
1513   gfstat_t statbuf;
1514
1515   if (unpack_filename (path, file, file_len))
1516     return -1;
1517
1518   if (stat (path, &statbuf) < 0)
1519     return -1;
1520
1521   return (GFC_IO_INT) statbuf.st_size;
1522 }
1523
1524 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1525
1526 /* inquire_sequential()-- Given a fortran string, determine if the
1527  * file is suitable for sequential access.  Returns a C-style
1528  * string. */
1529
1530 const char *
1531 inquire_sequential (const char *string, int len)
1532 {
1533   char path[PATH_MAX + 1];
1534   gfstat_t statbuf;
1535
1536   if (string == NULL ||
1537       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1538     return unknown;
1539
1540   if (S_ISREG (statbuf.st_mode) ||
1541       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1542     return unknown;
1543
1544   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1545     return no;
1546
1547   return unknown;
1548 }
1549
1550
1551 /* inquire_direct()-- Given a fortran string, determine if the file is
1552  * suitable for direct access.  Returns a C-style string. */
1553
1554 const char *
1555 inquire_direct (const char *string, int len)
1556 {
1557   char path[PATH_MAX + 1];
1558   gfstat_t statbuf;
1559
1560   if (string == NULL ||
1561       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1562     return unknown;
1563
1564   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1565     return unknown;
1566
1567   if (S_ISDIR (statbuf.st_mode) ||
1568       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1569     return no;
1570
1571   return unknown;
1572 }
1573
1574
1575 /* inquire_formatted()-- Given a fortran string, determine if the file
1576  * is suitable for formatted form.  Returns a C-style string. */
1577
1578 const char *
1579 inquire_formatted (const char *string, int len)
1580 {
1581   char path[PATH_MAX + 1];
1582   gfstat_t statbuf;
1583
1584   if (string == NULL ||
1585       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1586     return unknown;
1587
1588   if (S_ISREG (statbuf.st_mode) ||
1589       S_ISBLK (statbuf.st_mode) ||
1590       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1591     return unknown;
1592
1593   if (S_ISDIR (statbuf.st_mode))
1594     return no;
1595
1596   return unknown;
1597 }
1598
1599
1600 /* inquire_unformatted()-- Given a fortran string, determine if the file
1601  * is suitable for unformatted form.  Returns a C-style string. */
1602
1603 const char *
1604 inquire_unformatted (const char *string, int len)
1605 {
1606   return inquire_formatted (string, len);
1607 }
1608
1609
1610 #ifndef HAVE_ACCESS
1611
1612 #ifndef W_OK
1613 #define W_OK 2
1614 #endif
1615
1616 #ifndef R_OK
1617 #define R_OK 4
1618 #endif
1619
1620 /* Fallback implementation of access() on systems that don't have it.
1621    Only modes R_OK and W_OK are used in this file.  */
1622
1623 static int
1624 fallback_access (const char *path, int mode)
1625 {
1626   if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1627     return -1;
1628
1629   if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1630     return -1;
1631
1632   return 0;
1633 }
1634
1635 #undef access
1636 #define access fallback_access
1637 #endif
1638
1639
1640 /* inquire_access()-- Given a fortran string, determine if the file is
1641  * suitable for access. */
1642
1643 static const char *
1644 inquire_access (const char *string, int len, int mode)
1645 {
1646   char path[PATH_MAX + 1];
1647
1648   if (string == NULL || unpack_filename (path, string, len) ||
1649       access (path, mode) < 0)
1650     return no;
1651
1652   return yes;
1653 }
1654
1655
1656 /* inquire_read()-- Given a fortran string, determine if the file is
1657  * suitable for READ access. */
1658
1659 const char *
1660 inquire_read (const char *string, int len)
1661 {
1662   return inquire_access (string, len, R_OK);
1663 }
1664
1665
1666 /* inquire_write()-- Given a fortran string, determine if the file is
1667  * suitable for READ access. */
1668
1669 const char *
1670 inquire_write (const char *string, int len)
1671 {
1672   return inquire_access (string, len, W_OK);
1673 }
1674
1675
1676 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1677  * suitable for read and write access. */
1678
1679 const char *
1680 inquire_readwrite (const char *string, int len)
1681 {
1682   return inquire_access (string, len, R_OK | W_OK);
1683 }
1684
1685
1686 /* file_length()-- Return the file length in bytes, -1 if unknown */
1687
1688 gfc_offset
1689 file_length (stream * s)
1690 {
1691   gfc_offset curr, end;
1692   if (!is_seekable (s))
1693     return -1;
1694   curr = stell (s);
1695   if (curr == -1)
1696     return curr;
1697   end = sseek (s, 0, SEEK_END);
1698   sseek (s, curr, SEEK_SET);
1699   return end;
1700 }
1701
1702
1703 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1704  * it is not */
1705
1706 int
1707 is_seekable (stream *s)
1708 {
1709   /* By convention, if file_length == -1, the file is not
1710      seekable.  */
1711   return ((unix_stream *) s)->file_length!=-1;
1712 }
1713
1714
1715 /* is_special()-- Return nonzero if the stream is not a regular file.  */
1716
1717 int
1718 is_special (stream *s)
1719 {
1720   return ((unix_stream *) s)->special_file;
1721 }
1722
1723
1724 int
1725 stream_isatty (stream *s)
1726 {
1727   return isatty (((unix_stream *) s)->fd);
1728 }
1729
1730 char *
1731 stream_ttyname (stream *s __attribute__ ((unused)))
1732 {
1733 #ifdef HAVE_TTYNAME
1734   return ttyname (((unix_stream *) s)->fd);
1735 #else
1736   return NULL;
1737 #endif
1738 }
1739
1740
1741 /* How files are stored:  This is an operating-system specific issue,
1742    and therefore belongs here.  There are three cases to consider.
1743
1744    Direct Access:
1745       Records are written as block of bytes corresponding to the record
1746       length of the file.  This goes for both formatted and unformatted
1747       records.  Positioning is done explicitly for each data transfer,
1748       so positioning is not much of an issue.
1749
1750    Sequential Formatted:
1751       Records are separated by newline characters.  The newline character
1752       is prohibited from appearing in a string.  If it does, this will be
1753       messed up on the next read.  End of file is also the end of a record.
1754
1755    Sequential Unformatted:
1756       In this case, we are merely copying bytes to and from main storage,
1757       yet we need to keep track of varying record lengths.  We adopt
1758       the solution used by f2c.  Each record contains a pair of length
1759       markers:
1760
1761         Length of record n in bytes
1762         Data of record n
1763         Length of record n in bytes
1764
1765         Length of record n+1 in bytes
1766         Data of record n+1
1767         Length of record n+1 in bytes
1768
1769      The length is stored at the end of a record to allow backspacing to the
1770      previous record.  Between data transfer statements, the file pointer
1771      is left pointing to the first length of the current record.
1772
1773      ENDFILE records are never explicitly stored.
1774
1775 */