OSDN Git Service

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