OSDN Git Service

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