OSDN Git Service

b3bd438c32dd6db7643dec2478d117cd730a4f2a
[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 = _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   int fd;
881
882   tempdir = getenv ("GFORTRAN_TMPDIR");
883   if (tempdir == NULL)
884     tempdir = getenv ("TMP");
885   if (tempdir == NULL)
886     tempdir = getenv ("TEMP");
887   if (tempdir == NULL)
888     tempdir = DEFAULT_TEMPDIR;
889
890   template = get_mem (strlen (tempdir) + 20);
891
892 #ifdef HAVE_MKSTEMP
893   sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
894
895   fd = mkstemp (template);
896
897 #else /* HAVE_MKSTEMP */
898   fd = -1;
899   do
900     {
901       sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
902       if (!mktemp (template))
903         break;
904 #if defined(HAVE_CRLF) && defined(O_BINARY)
905       fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
906                  S_IREAD | S_IWRITE);
907 #else
908       fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
909 #endif
910     }
911   while (fd == -1 && errno == EEXIST);
912
913 #endif /* HAVE_MKSTEMP */
914
915   if (fd < 0)
916     free_mem (template);
917   else
918     {
919       opp->file = template;
920       opp->file_len = strlen (template);        /* Don't include trailing nul */
921     }
922
923   return fd;
924 }
925
926
927 /* regular_file()-- Open a regular file.
928  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
929  * unless an error occurs.
930  * Returns the descriptor, which is less than zero on error. */
931
932 static int
933 regular_file (st_parameter_open *opp, unit_flags *flags)
934 {
935   char path[PATH_MAX + 1];
936   int mode;
937   int rwflag;
938   int crflag;
939   int fd;
940
941   if (unpack_filename (path, opp->file, opp->file_len))
942     {
943       errno = ENOENT;           /* Fake an OS error */
944       return -1;
945     }
946
947 #ifdef __CYGWIN__
948   if (opp->file_len == 7)
949     {
950       if (strncmp (path, "CONOUT$", 7) == 0
951           || strncmp (path, "CONERR$", 7) == 0)
952         {
953           fd = open ("/dev/conout", O_WRONLY);
954           flags->action = ACTION_WRITE;
955           return fd;
956         }
957     }
958
959   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
960     {
961       fd = open ("/dev/conin", O_RDONLY);
962       flags->action = ACTION_READ;
963       return fd;
964     }
965 #endif
966
967
968 #ifdef __MINGW32__
969   if (opp->file_len == 7)
970     {
971       if (strncmp (path, "CONOUT$", 7) == 0
972           || strncmp (path, "CONERR$", 7) == 0)
973         {
974           fd = open ("CONOUT$", O_WRONLY);
975           flags->action = ACTION_WRITE;
976           return fd;
977         }
978     }
979
980   if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
981     {
982       fd = open ("CONIN$", O_RDONLY);
983       flags->action = ACTION_READ;
984       return fd;
985     }
986 #endif
987
988   rwflag = 0;
989
990   switch (flags->action)
991     {
992     case ACTION_READ:
993       rwflag = O_RDONLY;
994       break;
995
996     case ACTION_WRITE:
997       rwflag = O_WRONLY;
998       break;
999
1000     case ACTION_READWRITE:
1001     case ACTION_UNSPECIFIED:
1002       rwflag = O_RDWR;
1003       break;
1004
1005     default:
1006       internal_error (&opp->common, "regular_file(): Bad action");
1007     }
1008
1009   switch (flags->status)
1010     {
1011     case STATUS_NEW:
1012       crflag = O_CREAT | O_EXCL;
1013       break;
1014
1015     case STATUS_OLD:            /* open will fail if the file does not exist*/
1016       crflag = 0;
1017       break;
1018
1019     case STATUS_UNKNOWN:
1020     case STATUS_SCRATCH:
1021       crflag = O_CREAT;
1022       break;
1023
1024     case STATUS_REPLACE:
1025       crflag = O_CREAT | O_TRUNC;
1026       break;
1027
1028     default:
1029       internal_error (&opp->common, "regular_file(): Bad status");
1030     }
1031
1032   /* rwflag |= O_LARGEFILE; */
1033
1034 #if defined(HAVE_CRLF) && defined(O_BINARY)
1035   crflag |= O_BINARY;
1036 #endif
1037
1038   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1039   fd = open (path, rwflag | crflag, mode);
1040   if (flags->action != ACTION_UNSPECIFIED)
1041     return fd;
1042
1043   if (fd >= 0)
1044     {
1045       flags->action = ACTION_READWRITE;
1046       return fd;
1047     }
1048   if (errno != EACCES && errno != EROFS)
1049      return fd;
1050
1051   /* retry for read-only access */
1052   rwflag = O_RDONLY;
1053   fd = open (path, rwflag | crflag, mode);
1054   if (fd >=0)
1055     {
1056       flags->action = ACTION_READ;
1057       return fd;                /* success */
1058     }
1059   
1060   if (errno != EACCES)
1061     return fd;                  /* failure */
1062
1063   /* retry for write-only access */
1064   rwflag = O_WRONLY;
1065   fd = open (path, rwflag | crflag, mode);
1066   if (fd >=0)
1067     {
1068       flags->action = ACTION_WRITE;
1069       return fd;                /* success */
1070     }
1071   return fd;                    /* failure */
1072 }
1073
1074
1075 /* open_external()-- Open an external file, unix specific version.
1076  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1077  * Returns NULL on operating system error. */
1078
1079 stream *
1080 open_external (st_parameter_open *opp, unit_flags *flags)
1081 {
1082   int fd, prot;
1083
1084   if (flags->status == STATUS_SCRATCH)
1085     {
1086       fd = tempfile (opp);
1087       if (flags->action == ACTION_UNSPECIFIED)
1088         flags->action = ACTION_READWRITE;
1089
1090 #if HAVE_UNLINK_OPEN_FILE
1091       /* We can unlink scratch files now and it will go away when closed. */
1092       if (fd >= 0)
1093         unlink (opp->file);
1094 #endif
1095     }
1096   else
1097     {
1098       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1099        * if it succeeds */
1100       fd = regular_file (opp, flags);
1101     }
1102
1103   if (fd < 0)
1104     return NULL;
1105   fd = fix_fd (fd);
1106
1107   switch (flags->action)
1108     {
1109     case ACTION_READ:
1110       prot = PROT_READ;
1111       break;
1112
1113     case ACTION_WRITE:
1114       prot = PROT_WRITE;
1115       break;
1116
1117     case ACTION_READWRITE:
1118       prot = PROT_READ | PROT_WRITE;
1119       break;
1120
1121     default:
1122       internal_error (&opp->common, "open_external(): Bad action");
1123     }
1124
1125   return fd_to_stream (fd, prot);
1126 }
1127
1128
1129 /* input_stream()-- Return a stream pointer to the default input stream.
1130  * Called on initialization. */
1131
1132 stream *
1133 input_stream (void)
1134 {
1135   return fd_to_stream (STDIN_FILENO, PROT_READ);
1136 }
1137
1138
1139 /* output_stream()-- Return a stream pointer to the default output stream.
1140  * Called on initialization. */
1141
1142 stream *
1143 output_stream (void)
1144 {
1145   stream * s;
1146
1147 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1148   setmode (STDOUT_FILENO, O_BINARY);
1149 #endif
1150
1151   s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1152   return s;
1153 }
1154
1155
1156 /* error_stream()-- Return a stream pointer to the default error stream.
1157  * Called on initialization. */
1158
1159 stream *
1160 error_stream (void)
1161 {
1162   stream * s;
1163
1164 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1165   setmode (STDERR_FILENO, O_BINARY);
1166 #endif
1167
1168   s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
1169   return s;
1170 }
1171
1172
1173 /* st_vprintf()-- vprintf function for error output.  To avoid buffer
1174    overruns, we limit the length of the buffer to ST_VPRINTF_SIZE.  2k
1175    is big enough to completely fill a 80x25 terminal, so it shuld be
1176    OK.  We use a direct write() because it is simpler and least likely
1177    to be clobbered by memory corruption.  Writing an error message
1178    longer than that is an error.  */
1179
1180 #define ST_VPRINTF_SIZE 2048
1181
1182 int
1183 st_vprintf (const char *format, va_list ap)
1184 {
1185   static char buffer[ST_VPRINTF_SIZE];
1186   int written;
1187   int fd;
1188
1189   fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1190 #ifdef HAVE_VSNPRINTF
1191   written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1192 #else
1193   written = vsprintf(buffer, format, ap);
1194
1195   if (written >= ST_VPRINTF_SIZE-1)
1196     {
1197       /* The error message was longer than our buffer.  Ouch.  Because
1198          we may have messed up things badly, report the error and
1199          quit.  */
1200 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1201       write (fd, buffer, ST_VPRINTF_SIZE-1);
1202       write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1203       sys_exit(2);
1204 #undef ERROR_MESSAGE
1205
1206     }
1207 #endif
1208
1209   written = write (fd, buffer, written);
1210   return written;
1211 }
1212
1213 /* st_printf()-- printf() function for error output.  This just calls
1214    st_vprintf() to do the actual work.  */
1215
1216 int
1217 st_printf (const char *format, ...)
1218 {
1219   int written;
1220   va_list ap;
1221   va_start (ap, format);
1222   written = st_vprintf(format, ap);
1223   va_end (ap);
1224   return written;
1225 }
1226
1227
1228 /* compare_file_filename()-- Given an open stream and a fortran string
1229  * that is a filename, figure out if the file is the same as the
1230  * filename. */
1231
1232 int
1233 compare_file_filename (gfc_unit *u, const char *name, int len)
1234 {
1235   char path[PATH_MAX + 1];
1236   gfstat_t st1;
1237 #ifdef HAVE_WORKING_STAT
1238   gfstat_t st2;
1239 #else
1240 # ifdef __MINGW32__
1241   uint64_t id1, id2;
1242 # endif
1243 #endif
1244
1245   if (unpack_filename (path, name, len))
1246     return 0;                   /* Can't be the same */
1247
1248   /* If the filename doesn't exist, then there is no match with the
1249    * existing file. */
1250
1251   if (stat (path, &st1) < 0)
1252     return 0;
1253
1254 #ifdef HAVE_WORKING_STAT
1255   fstat (((unix_stream *) (u->s))->fd, &st2);
1256   return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1257 #else
1258
1259 # ifdef __MINGW32__
1260   /* We try to match files by a unique ID.  On some filesystems (network
1261      fs and FAT), we can't generate this unique ID, and will simply compare
1262      filenames.  */
1263   id1 = id_from_path (path);
1264   id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1265   if (id1 || id2)
1266     return (id1 == id2);
1267 # endif
1268
1269   if (len != u->file_len)
1270     return 0;
1271   return (memcmp(path, u->file, len) == 0);
1272 #endif
1273 }
1274
1275
1276 #ifdef HAVE_WORKING_STAT
1277 # define FIND_FILE0_DECL gfstat_t *st
1278 # define FIND_FILE0_ARGS st
1279 #else
1280 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1281 # define FIND_FILE0_ARGS id, file, file_len
1282 #endif
1283
1284 /* find_file0()-- Recursive work function for find_file() */
1285
1286 static gfc_unit *
1287 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1288 {
1289   gfc_unit *v;
1290 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1291   uint64_t id1;
1292 #endif
1293
1294   if (u == NULL)
1295     return NULL;
1296
1297 #ifdef HAVE_WORKING_STAT
1298   if (u->s != NULL
1299       && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
1300       st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
1301     return u;
1302 #else
1303 # ifdef __MINGW32__ 
1304   if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1305     {
1306       if (id == id1)
1307         return u;
1308     }
1309   else
1310 # endif
1311     if (compare_string (u->file_len, u->file, file_len, file) == 0)
1312       return u;
1313 #endif
1314
1315   v = find_file0 (u->left, FIND_FILE0_ARGS);
1316   if (v != NULL)
1317     return v;
1318
1319   v = find_file0 (u->right, FIND_FILE0_ARGS);
1320   if (v != NULL)
1321     return v;
1322
1323   return NULL;
1324 }
1325
1326
1327 /* find_file()-- Take the current filename and see if there is a unit
1328  * that has the file already open.  Returns a pointer to the unit if so. */
1329
1330 gfc_unit *
1331 find_file (const char *file, gfc_charlen_type file_len)
1332 {
1333   char path[PATH_MAX + 1];
1334   gfstat_t st[2];
1335   gfc_unit *u;
1336 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1337   uint64_t id = 0ULL;
1338 #endif
1339
1340   if (unpack_filename (path, file, file_len))
1341     return NULL;
1342
1343   if (stat (path, &st[0]) < 0)
1344     return NULL;
1345
1346 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1347   id = id_from_path (path);
1348 #endif
1349
1350   __gthread_mutex_lock (&unit_lock);
1351 retry:
1352   u = find_file0 (unit_root, FIND_FILE0_ARGS);
1353   if (u != NULL)
1354     {
1355       /* Fast path.  */
1356       if (! __gthread_mutex_trylock (&u->lock))
1357         {
1358           /* assert (u->closed == 0); */
1359           __gthread_mutex_unlock (&unit_lock);
1360           return u;
1361         }
1362
1363       inc_waiting_locked (u);
1364     }
1365   __gthread_mutex_unlock (&unit_lock);
1366   if (u != NULL)
1367     {
1368       __gthread_mutex_lock (&u->lock);
1369       if (u->closed)
1370         {
1371           __gthread_mutex_lock (&unit_lock);
1372           __gthread_mutex_unlock (&u->lock);
1373           if (predec_waiting_locked (u) == 0)
1374             free_mem (u);
1375           goto retry;
1376         }
1377
1378       dec_waiting_unlocked (u);
1379     }
1380   return u;
1381 }
1382
1383 static gfc_unit *
1384 flush_all_units_1 (gfc_unit *u, int min_unit)
1385 {
1386   while (u != NULL)
1387     {
1388       if (u->unit_number > min_unit)
1389         {
1390           gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1391           if (r != NULL)
1392             return r;
1393         }
1394       if (u->unit_number >= min_unit)
1395         {
1396           if (__gthread_mutex_trylock (&u->lock))
1397             return u;
1398           if (u->s)
1399             sflush (u->s);
1400           __gthread_mutex_unlock (&u->lock);
1401         }
1402       u = u->right;
1403     }
1404   return NULL;
1405 }
1406
1407 void
1408 flush_all_units (void)
1409 {
1410   gfc_unit *u;
1411   int min_unit = 0;
1412
1413   __gthread_mutex_lock (&unit_lock);
1414   do
1415     {
1416       u = flush_all_units_1 (unit_root, min_unit);
1417       if (u != NULL)
1418         inc_waiting_locked (u);
1419       __gthread_mutex_unlock (&unit_lock);
1420       if (u == NULL)
1421         return;
1422
1423       __gthread_mutex_lock (&u->lock);
1424
1425       min_unit = u->unit_number + 1;
1426
1427       if (u->closed == 0)
1428         {
1429           sflush (u->s);
1430           __gthread_mutex_lock (&unit_lock);
1431           __gthread_mutex_unlock (&u->lock);
1432           (void) predec_waiting_locked (u);
1433         }
1434       else
1435         {
1436           __gthread_mutex_lock (&unit_lock);
1437           __gthread_mutex_unlock (&u->lock);
1438           if (predec_waiting_locked (u) == 0)
1439             free_mem (u);
1440         }
1441     }
1442   while (1);
1443 }
1444
1445
1446 /* delete_file()-- Given a unit structure, delete the file associated
1447  * with the unit.  Returns nonzero if something went wrong. */
1448
1449 int
1450 delete_file (gfc_unit * u)
1451 {
1452   char path[PATH_MAX + 1];
1453
1454   if (unpack_filename (path, u->file, u->file_len))
1455     {                           /* Shouldn't be possible */
1456       errno = ENOENT;
1457       return 1;
1458     }
1459
1460   return unlink (path);
1461 }
1462
1463
1464 /* file_exists()-- Returns nonzero if the current filename exists on
1465  * the system */
1466
1467 int
1468 file_exists (const char *file, gfc_charlen_type file_len)
1469 {
1470   char path[PATH_MAX + 1];
1471   gfstat_t statbuf;
1472
1473   if (unpack_filename (path, file, file_len))
1474     return 0;
1475
1476   if (stat (path, &statbuf) < 0)
1477     return 0;
1478
1479   return 1;
1480 }
1481
1482
1483 /* file_size()-- Returns the size of the file.  */
1484
1485 GFC_IO_INT
1486 file_size (const char *file, gfc_charlen_type file_len)
1487 {
1488   char path[PATH_MAX + 1];
1489   gfstat_t statbuf;
1490
1491   if (unpack_filename (path, file, file_len))
1492     return -1;
1493
1494   if (stat (path, &statbuf) < 0)
1495     return -1;
1496
1497   return (GFC_IO_INT) statbuf.st_size;
1498 }
1499
1500 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1501
1502 /* inquire_sequential()-- Given a fortran string, determine if the
1503  * file is suitable for sequential access.  Returns a C-style
1504  * string. */
1505
1506 const char *
1507 inquire_sequential (const char *string, int len)
1508 {
1509   char path[PATH_MAX + 1];
1510   gfstat_t statbuf;
1511
1512   if (string == NULL ||
1513       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1514     return unknown;
1515
1516   if (S_ISREG (statbuf.st_mode) ||
1517       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1518     return unknown;
1519
1520   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1521     return no;
1522
1523   return unknown;
1524 }
1525
1526
1527 /* inquire_direct()-- Given a fortran string, determine if the file is
1528  * suitable for direct access.  Returns a C-style string. */
1529
1530 const char *
1531 inquire_direct (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) || S_ISBLK (statbuf.st_mode))
1541     return unknown;
1542
1543   if (S_ISDIR (statbuf.st_mode) ||
1544       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1545     return no;
1546
1547   return unknown;
1548 }
1549
1550
1551 /* inquire_formatted()-- Given a fortran string, determine if the file
1552  * is suitable for formatted form.  Returns a C-style string. */
1553
1554 const char *
1555 inquire_formatted (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) ||
1565       S_ISBLK (statbuf.st_mode) ||
1566       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1567     return unknown;
1568
1569   if (S_ISDIR (statbuf.st_mode))
1570     return no;
1571
1572   return unknown;
1573 }
1574
1575
1576 /* inquire_unformatted()-- Given a fortran string, determine if the file
1577  * is suitable for unformatted form.  Returns a C-style string. */
1578
1579 const char *
1580 inquire_unformatted (const char *string, int len)
1581 {
1582   return inquire_formatted (string, len);
1583 }
1584
1585
1586 #ifndef HAVE_ACCESS
1587
1588 #ifndef W_OK
1589 #define W_OK 2
1590 #endif
1591
1592 #ifndef R_OK
1593 #define R_OK 4
1594 #endif
1595
1596 /* Fallback implementation of access() on systems that don't have it.
1597    Only modes R_OK and W_OK are used in this file.  */
1598
1599 static int
1600 fallback_access (const char *path, int mode)
1601 {
1602   if ((mode & R_OK) && open (path, O_RDONLY) < 0)
1603     return -1;
1604
1605   if ((mode & W_OK) && open (path, O_WRONLY) < 0)
1606     return -1;
1607
1608   return 0;
1609 }
1610
1611 #undef access
1612 #define access fallback_access
1613 #endif
1614
1615
1616 /* inquire_access()-- Given a fortran string, determine if the file is
1617  * suitable for access. */
1618
1619 static const char *
1620 inquire_access (const char *string, int len, int mode)
1621 {
1622   char path[PATH_MAX + 1];
1623
1624   if (string == NULL || unpack_filename (path, string, len) ||
1625       access (path, mode) < 0)
1626     return no;
1627
1628   return yes;
1629 }
1630
1631
1632 /* inquire_read()-- Given a fortran string, determine if the file is
1633  * suitable for READ access. */
1634
1635 const char *
1636 inquire_read (const char *string, int len)
1637 {
1638   return inquire_access (string, len, R_OK);
1639 }
1640
1641
1642 /* inquire_write()-- Given a fortran string, determine if the file is
1643  * suitable for READ access. */
1644
1645 const char *
1646 inquire_write (const char *string, int len)
1647 {
1648   return inquire_access (string, len, W_OK);
1649 }
1650
1651
1652 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1653  * suitable for read and write access. */
1654
1655 const char *
1656 inquire_readwrite (const char *string, int len)
1657 {
1658   return inquire_access (string, len, R_OK | W_OK);
1659 }
1660
1661
1662 /* file_length()-- Return the file length in bytes, -1 if unknown */
1663
1664 gfc_offset
1665 file_length (stream * s)
1666 {
1667   gfc_offset curr, end;
1668   if (!is_seekable (s))
1669     return -1;
1670   curr = stell (s);
1671   if (curr == -1)
1672     return curr;
1673   end = sseek (s, 0, SEEK_END);
1674   sseek (s, curr, SEEK_SET);
1675   return end;
1676 }
1677
1678
1679 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1680  * it is not */
1681
1682 int
1683 is_seekable (stream *s)
1684 {
1685   /* By convention, if file_length == -1, the file is not
1686      seekable.  */
1687   return ((unix_stream *) s)->file_length!=-1;
1688 }
1689
1690
1691 /* is_special()-- Return nonzero if the stream is not a regular file.  */
1692
1693 int
1694 is_special (stream *s)
1695 {
1696   return ((unix_stream *) s)->special_file;
1697 }
1698
1699
1700 int
1701 stream_isatty (stream *s)
1702 {
1703   return isatty (((unix_stream *) s)->fd);
1704 }
1705
1706 char *
1707 stream_ttyname (stream *s __attribute__ ((unused)))
1708 {
1709 #ifdef HAVE_TTYNAME
1710   return ttyname (((unix_stream *) s)->fd);
1711 #else
1712   return NULL;
1713 #endif
1714 }
1715
1716
1717 /* How files are stored:  This is an operating-system specific issue,
1718    and therefore belongs here.  There are three cases to consider.
1719
1720    Direct Access:
1721       Records are written as block of bytes corresponding to the record
1722       length of the file.  This goes for both formatted and unformatted
1723       records.  Positioning is done explicitly for each data transfer,
1724       so positioning is not much of an issue.
1725
1726    Sequential Formatted:
1727       Records are separated by newline characters.  The newline character
1728       is prohibited from appearing in a string.  If it does, this will be
1729       messed up on the next read.  End of file is also the end of a record.
1730
1731    Sequential Unformatted:
1732       In this case, we are merely copying bytes to and from main storage,
1733       yet we need to keep track of varying record lengths.  We adopt
1734       the solution used by f2c.  Each record contains a pair of length
1735       markers:
1736
1737         Length of record n in bytes
1738         Data of record n
1739         Length of record n in bytes
1740
1741         Length of record n+1 in bytes
1742         Data of record n+1
1743         Length of record n+1 in bytes
1744
1745      The length is stored at the end of a record to allow backspacing to the
1746      previous record.  Between data transfer statements, the file pointer
1747      is left pointing to the first length of the current record.
1748
1749      ENDFILE records are never explicitly stored.
1750
1751 */