OSDN Git Service

1a4beddfc06734e81c8d2d86d0fa7dacf83731ff
[pf3gnuchains/gcc-fork.git] / libgfortran / io / unix.c
1 /* Copyright (C) 2002, 2003, 2004, 2005
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 "config.h"
34 #include <stdlib.h>
35 #include <limits.h>
36
37 #include <unistd.h>
38 #include <stdio.h>
39 #include <sys/stat.h>
40 #include <fcntl.h>
41
42 #ifdef HAVE_SYS_MMAN_H
43 #include <sys/mman.h>
44 #endif
45 #include <string.h>
46 #include <errno.h>
47
48 #include "libgfortran.h"
49 #include "io.h"
50
51 #ifndef PATH_MAX
52 #define PATH_MAX 1024
53 #endif
54
55 #ifndef MAP_FAILED
56 #define MAP_FAILED ((void *) -1)
57 #endif
58
59 #ifndef PROT_READ
60 #define PROT_READ 1
61 #endif
62
63 #ifndef PROT_WRITE
64 #define PROT_WRITE 2
65 #endif
66
67 /* These flags aren't defined on all targets (mingw32), so provide them
68    here.  */
69 #ifndef S_IRGRP
70 #define S_IRGRP 0
71 #endif
72
73 #ifndef S_IWGRP
74 #define S_IWGRP 0
75 #endif
76
77 #ifndef S_IROTH
78 #define S_IROTH 0
79 #endif
80
81 #ifndef S_IWOTH
82 #define S_IWOTH 0
83 #endif
84
85 /* This implementation of stream I/O is based on the paper:
86  *
87  *  "Exploiting the advantages of mapped files for stream I/O",
88  *  O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
89  *  USENIX conference", p. 27-42.
90  *
91  * It differs in a number of ways from the version described in the
92  * paper.  First of all, threads are not an issue during I/O and we
93  * also don't have to worry about having multiple regions, since
94  * fortran's I/O model only allows you to be one place at a time.
95  *
96  * On the other hand, we have to be able to writing at the end of a
97  * stream, read from the start of a stream or read and write blocks of
98  * bytes from an arbitrary position.  After opening a file, a pointer
99  * to a stream structure is returned, which is used to handle file
100  * accesses until the file is closed.
101  *
102  * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
103  * pointer to a block of memory that mirror the file at position
104  * 'where' that is 'len' bytes long.  The len integer is updated to
105  * reflect how many bytes were actually read.  The only reason for a
106  * short read is end of file.  The file pointer is updated.  The
107  * pointer is valid until the next call to salloc_*.
108  *
109  * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
110  * a pointer to a block of memory that is updated to reflect the state
111  * of the file.  The length of the buffer is always equal to that
112  * requested.  The buffer must be completely set by the caller.  When
113  * data has been written, the sfree() function must be called to
114  * indicate that the caller is done writing data to the buffer.  This
115  * may or may not cause a physical write.
116  *
117  * Short forms of these are salloc_r() and salloc_w() which drop the
118  * 'where' parameter and use the current file pointer. */
119
120
121 #define BUFFER_SIZE 8192
122
123 typedef struct
124 {
125   stream st;
126
127   int fd;
128   gfc_offset buffer_offset;     /* File offset of the start of the buffer */
129   gfc_offset physical_offset;   /* Current physical file offset */
130   gfc_offset logical_offset;    /* Current logical file offset */
131   gfc_offset dirty_offset;      /* Start of modified bytes in buffer */
132   gfc_offset file_length;       /* Length of the file, -1 if not seekable. */
133
134   char *buffer;
135   int len;                      /* Physical length of the current buffer */
136   int active;                   /* Length of valid bytes in the buffer */
137
138   int prot;
139   int ndirty;                   /* Dirty bytes starting at dirty_offset */
140
141   int special_file;             /* =1 if the fd refers to a special file */
142
143   unsigned unbuffered:1;
144
145   char small_buffer[BUFFER_SIZE];
146
147 }
148 unix_stream;
149
150 /*move_pos_offset()--  Move the record pointer right or left
151  *relative to current position */
152
153 int
154 move_pos_offset (stream* st, int pos_off)
155 {
156   unix_stream * str = (unix_stream*)st;
157   if (pos_off < 0)
158     {
159       str->logical_offset += pos_off;
160
161       if (str->dirty_offset + str->ndirty > str->logical_offset)
162         {
163           if (str->ndirty + pos_off > 0)
164             str->ndirty += pos_off;
165           else
166             {
167               str->dirty_offset +=  pos_off + pos_off;
168               str->ndirty = 0;
169             }
170         }
171
172     return pos_off;
173   }
174   return 0;
175 }
176
177
178 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
179  * standard descriptors, returning a non-standard descriptor.  If the
180  * user specifies that system errors should go to standard output,
181  * then closes standard output, we don't want the system errors to a
182  * file that has been given file descriptor 1 or 0.  We want to send
183  * the error to the invalid descriptor. */
184
185 static int
186 fix_fd (int fd)
187 {
188   int input, output, error;
189
190   input = output = error = 0;
191
192   /* Unix allocates the lowest descriptors first, so a loop is not
193      required, but this order is. */
194
195   if (fd == STDIN_FILENO)
196     {
197       fd = dup (fd);
198       input = 1;
199     }
200   if (fd == STDOUT_FILENO)
201     {
202       fd = dup (fd);
203       output = 1;
204     }
205   if (fd == STDERR_FILENO)
206     {
207       fd = dup (fd);
208       error = 1;
209     }
210
211   if (input)
212     close (STDIN_FILENO);
213   if (output)
214     close (STDOUT_FILENO);
215   if (error)
216     close (STDERR_FILENO);
217
218   return fd;
219 }
220
221
222 /* write()-- Write a buffer to a descriptor, allowing for short writes */
223
224 static int
225 writen (int fd, char *buffer, int len)
226 {
227   int n, n0;
228
229   n0 = len;
230
231   while (len > 0)
232     {
233       n = write (fd, buffer, len);
234       if (n < 0)
235         return n;
236
237       buffer += n;
238       len -= n;
239     }
240
241   return n0;
242 }
243
244
245 #if 0
246 /* readn()-- Read bytes into a buffer, allowing for short reads.  If
247  * fewer than len bytes are returned, it is because we've hit the end
248  * of file. */
249
250 static int
251 readn (int fd, char *buffer, int len)
252 {
253   int nread, n;
254
255   nread = 0;
256
257   while (len > 0)
258     {
259       n = read (fd, buffer, len);
260       if (n < 0)
261         return n;
262
263       if (n == 0)
264         return nread;
265
266       buffer += n;
267       nread += n;
268       len -= n;
269     }
270
271   return nread;
272 }
273 #endif
274
275
276 /* get_oserror()-- Get the most recent operating system error.  For
277  * unix, this is errno. */
278
279 const char *
280 get_oserror (void)
281 {
282   return strerror (errno);
283 }
284
285
286 /* sys_exit()-- Terminate the program with an exit code */
287
288 void
289 sys_exit (int code)
290 {
291   exit (code);
292 }
293
294
295 /*********************************************************************
296     File descriptor stream functions
297 *********************************************************************/
298
299 /* fd_flush()-- Write bytes that need to be written */
300
301 static try
302 fd_flush (unix_stream * s)
303 {
304   if (s->ndirty == 0)
305     return SUCCESS;;
306
307   if (s->physical_offset != s->dirty_offset &&
308       lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
309     return FAILURE;
310
311   if (writen (s->fd, s->buffer + (s->dirty_offset - s->buffer_offset),
312               s->ndirty) < 0)
313     return FAILURE;
314
315   s->physical_offset = s->dirty_offset + s->ndirty;
316
317   /* don't increment file_length if the file is non-seekable */
318   if (s->file_length != -1 && s->physical_offset > s->file_length)
319     s->file_length = s->physical_offset;
320   s->ndirty = 0;
321
322   return SUCCESS;
323 }
324
325
326 /* fd_alloc()-- Arrange a buffer such that the salloc() request can be
327  * satisfied.  This subroutine gets the buffer ready for whatever is
328  * to come next. */
329
330 static void
331 fd_alloc (unix_stream * s, gfc_offset where,
332           int *len __attribute__ ((unused)))
333 {
334   char *new_buffer;
335   int n, read_len;
336
337   if (*len <= BUFFER_SIZE)
338     {
339       new_buffer = s->small_buffer;
340       read_len = BUFFER_SIZE;
341     }
342   else
343     {
344       new_buffer = get_mem (*len);
345       read_len = *len;
346     }
347
348   /* Salvage bytes currently within the buffer.  This is important for
349    * devices that cannot seek. */
350
351   if (s->buffer != NULL && s->buffer_offset <= where &&
352       where <= s->buffer_offset + s->active)
353     {
354
355       n = s->active - (where - s->buffer_offset);
356       memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
357
358       s->active = n;
359     }
360   else
361     {                           /* new buffer starts off empty */
362       s->active = 0;
363     }
364
365   s->buffer_offset = where;
366
367   /* free the old buffer if necessary */
368
369   if (s->buffer != NULL && s->buffer != s->small_buffer)
370     free_mem (s->buffer);
371
372   s->buffer = new_buffer;
373   s->len = read_len;
374 }
375
376
377 /* fd_alloc_r_at()-- Allocate a stream buffer for reading.  Either
378  * we've already buffered the data or we need to load it.  Returns
379  * NULL on I/O error. */
380
381 static char *
382 fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
383 {
384   gfc_offset m;
385   int n;
386
387   if (where == -1)
388     where = s->logical_offset;
389
390   if (s->buffer != NULL && s->buffer_offset <= where &&
391       where + *len <= s->buffer_offset + s->active)
392     {
393
394       /* Return a position within the current buffer */
395
396       s->logical_offset = where + *len;
397       return s->buffer + where - s->buffer_offset;
398     }
399
400   fd_alloc (s, where, len);
401
402   m = where + s->active;
403
404   if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
405     return NULL;
406
407   n = read (s->fd, s->buffer + s->active, s->len - s->active);
408   if (n < 0)
409     return NULL;
410
411   s->physical_offset = where + n;
412
413   s->active += n;
414   if (s->active < *len)
415     *len = s->active;           /* Bytes actually available */
416
417   s->logical_offset = where + *len;
418
419   return s->buffer;
420 }
421
422
423 /* fd_alloc_w_at()-- Allocate a stream buffer for writing.  Either
424  * we've already buffered the data or we need to load it. */
425
426 static char *
427 fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
428 {
429   gfc_offset n;
430
431   if (where == -1)
432     where = s->logical_offset;
433
434   if (s->buffer == NULL || s->buffer_offset > where ||
435       where + *len > s->buffer_offset + s->len)
436     {
437
438       if (fd_flush (s) == FAILURE)
439         return NULL;
440       fd_alloc (s, where, len);
441     }
442
443   /* Return a position within the current buffer */
444   if (s->ndirty == 0 
445       || where > s->dirty_offset + s->ndirty    
446       || s->dirty_offset > where + *len)
447     {  /* Discontiguous blocks, start with a clean buffer.  */  
448         /* Flush the buffer.  */  
449        if (s->ndirty != 0)    
450          fd_flush (s);  
451        s->dirty_offset = where;  
452        s->ndirty = *len;
453     }
454   else
455     {  
456       gfc_offset start;  /* Merge with the existing data.  */  
457       if (where < s->dirty_offset)    
458         start = where;  
459       else    
460         start = s->dirty_offset;  
461       if (where + *len > s->dirty_offset + s->ndirty)    
462         s->ndirty = where + *len - start;  
463       else    
464         s->ndirty = s->dirty_offset + s->ndirty - start;  
465         s->dirty_offset = start;
466     }
467
468   s->logical_offset = where + *len;
469
470   if (where + *len > s->file_length)
471     s->file_length = where + *len;
472
473   n = s->logical_offset - s->buffer_offset;
474   if (n > s->active)
475     s->active = n;
476
477   return s->buffer + where - s->buffer_offset;
478 }
479
480
481 static try
482 fd_sfree (unix_stream * s)
483 {
484   if (s->ndirty != 0 &&
485       (s->buffer != s->small_buffer || options.all_unbuffered ||
486        s->unbuffered))
487     return fd_flush (s);
488
489   return SUCCESS;
490 }
491
492
493 static int
494 fd_seek (unix_stream * s, gfc_offset offset)
495 {
496   s->physical_offset = s->logical_offset = offset;
497
498   return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
499 }
500
501
502 /* truncate_file()-- Given a unit, truncate the file at the current
503  * position.  Sets the physical location to the new end of the file.
504  * Returns nonzero on error. */
505
506 static try
507 fd_truncate (unix_stream * s)
508 {
509   if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
510     return FAILURE;
511
512   /* non-seekable files, like terminals and fifo's fail the lseek.
513      Using ftruncate on a seekable special file (like /dev/null)
514      is undefined, so we treat it as if the ftruncate failed.
515   */
516 #ifdef HAVE_FTRUNCATE
517   if (s->special_file || ftruncate (s->fd, s->logical_offset))
518 #else
519 #ifdef HAVE_CHSIZE
520   if (s->special_file || chsize (s->fd, s->logical_offset))
521 #endif
522 #endif
523     {
524       s->physical_offset = s->file_length = 0;
525       return FAILURE;
526     }
527
528   s->physical_offset = s->file_length = s->logical_offset;
529
530   return SUCCESS;
531 }
532
533
534 static try
535 fd_close (unix_stream * s)
536 {
537   if (fd_flush (s) == FAILURE)
538     return FAILURE;
539
540   if (s->buffer != NULL && s->buffer != s->small_buffer)
541     free_mem (s->buffer);
542
543   if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO)
544     {
545       if (close (s->fd) < 0)
546         return FAILURE;
547     }
548
549   free_mem (s);
550
551   return SUCCESS;
552 }
553
554
555 static void
556 fd_open (unix_stream * s)
557 {
558   if (isatty (s->fd))
559     s->unbuffered = 1;
560
561   s->st.alloc_r_at = (void *) fd_alloc_r_at;
562   s->st.alloc_w_at = (void *) fd_alloc_w_at;
563   s->st.sfree = (void *) fd_sfree;
564   s->st.close = (void *) fd_close;
565   s->st.seek = (void *) fd_seek;
566   s->st.truncate = (void *) fd_truncate;
567
568   s->buffer = NULL;
569 }
570
571
572
573 /*********************************************************************
574   memory stream functions - These are used for internal files
575
576   The idea here is that a single stream structure is created and all
577   requests must be satisfied from it.  The location and size of the
578   buffer is the character variable supplied to the READ or WRITE
579   statement.
580
581 *********************************************************************/
582
583
584 static char *
585 mem_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
586 {
587   gfc_offset n;
588
589   if (where == -1)
590     where = s->logical_offset;
591
592   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
593     return NULL;
594
595   s->logical_offset = where + *len;
596
597   n = s->buffer_offset + s->active - where;
598   if (*len > n)
599     *len = n;
600
601   return s->buffer + (where - s->buffer_offset);
602 }
603
604
605 static char *
606 mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
607 {
608   gfc_offset m;
609
610   if (where == -1)
611     where = s->logical_offset;
612
613   m = where + *len;
614
615   if (where < s->buffer_offset || m > s->buffer_offset + s->active)
616     return NULL;
617
618   s->logical_offset = m;
619
620   return s->buffer + (where - s->buffer_offset);
621 }
622
623
624 static int
625 mem_seek (unix_stream * s, gfc_offset offset)
626 {
627   if (offset > s->file_length)
628     {
629       errno = ESPIPE;
630       return FAILURE;
631     }
632
633   s->logical_offset = offset;
634   return SUCCESS;
635 }
636
637
638 static int
639 mem_truncate (unix_stream * s __attribute__ ((unused)))
640 {
641   return SUCCESS;
642 }
643
644
645 static try
646 mem_close (unix_stream * s)
647 {
648   free_mem (s);
649
650   return SUCCESS;
651 }
652
653
654 static try
655 mem_sfree (unix_stream * s __attribute__ ((unused)))
656 {
657   return SUCCESS;
658 }
659
660
661
662 /*********************************************************************
663   Public functions -- A reimplementation of this module needs to
664   define functional equivalents of the following.
665 *********************************************************************/
666
667 /* empty_internal_buffer()-- Zero the buffer of Internal file */
668
669 void
670 empty_internal_buffer(stream *strm)
671 {
672   unix_stream * s = (unix_stream *) strm;
673   memset(s->buffer, ' ', s->file_length);
674 }
675
676 /* open_internal()-- Returns a stream structure from an internal file */
677
678 stream *
679 open_internal (char *base, int length)
680 {
681   unix_stream *s;
682
683   s = get_mem (sizeof (unix_stream));
684   memset (s, '\0', sizeof (unix_stream));
685
686   s->buffer = base;
687   s->buffer_offset = 0;
688
689   s->logical_offset = 0;
690   s->active = s->file_length = length;
691
692   s->st.alloc_r_at = (void *) mem_alloc_r_at;
693   s->st.alloc_w_at = (void *) mem_alloc_w_at;
694   s->st.sfree = (void *) mem_sfree;
695   s->st.close = (void *) mem_close;
696   s->st.seek = (void *) mem_seek;
697   s->st.truncate = (void *) mem_truncate;
698
699   return (stream *) s;
700 }
701
702
703 /* fd_to_stream()-- Given an open file descriptor, build a stream
704  * around it. */
705
706 static stream *
707 fd_to_stream (int fd, int prot)
708 {
709   struct stat statbuf;
710   unix_stream *s;
711
712   s = get_mem (sizeof (unix_stream));
713   memset (s, '\0', sizeof (unix_stream));
714
715   s->fd = fd;
716   s->buffer_offset = 0;
717   s->physical_offset = 0;
718   s->logical_offset = 0;
719   s->prot = prot;
720
721   /* Get the current length of the file. */
722
723   fstat (fd, &statbuf);
724   s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
725   s->special_file = !S_ISREG (statbuf.st_mode);
726
727   fd_open (s);
728
729   return (stream *) s;
730 }
731
732
733 /* Given the Fortran unit number, convert it to a C file descriptor.  */
734
735 int
736 unit_to_fd(int unit)
737 {
738   gfc_unit *us;
739
740   us = find_unit(unit);
741   if (us == NULL)
742     return -1;
743
744   return ((unix_stream *) us->s)->fd;
745 }
746
747
748 /* unpack_filename()-- Given a fortran string and a pointer to a
749  * buffer that is PATH_MAX characters, convert the fortran string to a
750  * C string in the buffer.  Returns nonzero if this is not possible.  */
751
752 int
753 unpack_filename (char *cstring, const char *fstring, int len)
754 {
755   len = fstrlen (fstring, len);
756   if (len >= PATH_MAX)
757     return 1;
758
759   memmove (cstring, fstring, len);
760   cstring[len] = '\0';
761
762   return 0;
763 }
764
765
766 /* tempfile()-- Generate a temporary filename for a scratch file and
767  * open it.  mkstemp() opens the file for reading and writing, but the
768  * library mode prevents anything that is not allowed.  The descriptor
769  * is returned, which is -1 on error.  The template is pointed to by 
770  * ioparm.file, which is copied into the unit structure
771  * and freed later. */
772
773 static int
774 tempfile (void)
775 {
776   const char *tempdir;
777   char *template;
778   int fd;
779
780   tempdir = getenv ("GFORTRAN_TMPDIR");
781   if (tempdir == NULL)
782     tempdir = getenv ("TMP");
783   if (tempdir == NULL)
784     tempdir = getenv ("TEMP");
785   if (tempdir == NULL)
786     tempdir = DEFAULT_TEMPDIR;
787
788   template = get_mem (strlen (tempdir) + 20);
789
790   st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
791
792 #ifdef HAVE_MKSTEMP
793
794   fd = mkstemp (template);
795
796 #else /* HAVE_MKSTEMP */
797
798   if (mktemp (template))
799     do
800 #ifdef HAVE_CRLF
801       fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
802                  S_IREAD | S_IWRITE);
803 #else
804       fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
805 #endif
806     while (!(fd == -1 && errno == EEXIST) && mktemp (template));
807   else
808     fd = -1;
809
810 #endif /* HAVE_MKSTEMP */
811
812   if (fd < 0)
813     free_mem (template);
814   else
815     {
816       ioparm.file = template;
817       ioparm.file_len = strlen (template);      /* Don't include trailing nul */
818     }
819
820   return fd;
821 }
822
823
824 /* regular_file()-- Open a regular file.
825  * Change flags->action if it is ACTION_UNSPECIFIED on entry,
826  * unless an error occurs.
827  * Returns the descriptor, which is less than zero on error. */
828
829 static int
830 regular_file (unit_flags *flags)
831 {
832   char path[PATH_MAX + 1];
833   int mode;
834   int rwflag;
835   int crflag;
836   int fd;
837
838   if (unpack_filename (path, ioparm.file, ioparm.file_len))
839     {
840       errno = ENOENT;           /* Fake an OS error */
841       return -1;
842     }
843
844   rwflag = 0;
845
846   switch (flags->action)
847     {
848     case ACTION_READ:
849       rwflag = O_RDONLY;
850       break;
851
852     case ACTION_WRITE:
853       rwflag = O_WRONLY;
854       break;
855
856     case ACTION_READWRITE:
857     case ACTION_UNSPECIFIED:
858       rwflag = O_RDWR;
859       break;
860
861     default:
862       internal_error ("regular_file(): Bad action");
863     }
864
865   switch (flags->status)
866     {
867     case STATUS_NEW:
868       crflag = O_CREAT | O_EXCL;
869       break;
870
871     case STATUS_OLD:            /* open will fail if the file does not exist*/
872       crflag = 0;
873       break;
874
875     case STATUS_UNKNOWN:
876     case STATUS_SCRATCH:
877       crflag = O_CREAT;
878       break;
879
880     case STATUS_REPLACE:
881         crflag = O_CREAT | O_TRUNC;
882       break;
883
884     default:
885       internal_error ("regular_file(): Bad status");
886     }
887
888   /* rwflag |= O_LARGEFILE; */
889
890 #ifdef HAVE_CRLF
891   crflag |= O_BINARY;
892 #endif
893
894   mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
895   fd = open (path, rwflag | crflag, mode);
896   if (flags->action != ACTION_UNSPECIFIED)
897       return fd;
898
899   if (fd >= 0)
900     {
901       flags->action = ACTION_READWRITE;
902       return fd;
903     }
904   if (errno != EACCES)
905      return fd;
906
907   /* retry for read-only access */
908   rwflag = O_RDONLY;
909   fd = open (path, rwflag | crflag, mode);
910   if (fd >=0)
911     {
912       flags->action = ACTION_READ;
913       return fd;               /* success */
914     }
915   
916   if (errno != EACCES)
917     return fd;                 /* failure */
918
919   /* retry for write-only access */
920   rwflag = O_WRONLY;
921   fd = open (path, rwflag | crflag, mode);
922   if (fd >=0)
923     {
924       flags->action = ACTION_WRITE;
925       return fd;               /* success */
926     }
927   return fd;                   /* failure */
928 }
929
930
931 /* open_external()-- Open an external file, unix specific version.
932  * Change flags->action if it is ACTION_UNSPECIFIED on entry.
933  * Returns NULL on operating system error. */
934
935 stream *
936 open_external (unit_flags *flags)
937 {
938   int fd, prot;
939
940   if (flags->status == STATUS_SCRATCH)
941     {
942       fd = tempfile ();
943       if (flags->action == ACTION_UNSPECIFIED)
944         flags->action = ACTION_READWRITE;
945
946 #if HAVE_UNLINK_OPEN_FILE
947       /* We can unlink scratch files now and it will go away when closed. */
948       unlink (ioparm.file);
949 #endif
950     }
951   else
952     {
953       /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
954        * if it succeeds */
955       fd = regular_file (flags);
956     }
957
958   if (fd < 0)
959     return NULL;
960   fd = fix_fd (fd);
961
962   switch (flags->action)
963     {
964     case ACTION_READ:
965       prot = PROT_READ;
966       break;
967
968     case ACTION_WRITE:
969       prot = PROT_WRITE;
970       break;
971
972     case ACTION_READWRITE:
973       prot = PROT_READ | PROT_WRITE;
974       break;
975
976     default:
977       internal_error ("open_external(): Bad action");
978     }
979
980   return fd_to_stream (fd, prot);
981 }
982
983
984 /* input_stream()-- Return a stream pointer to the default input stream.
985  * Called on initialization. */
986
987 stream *
988 input_stream (void)
989 {
990   return fd_to_stream (STDIN_FILENO, PROT_READ);
991 }
992
993
994 /* output_stream()-- Return a stream pointer to the default output stream.
995  * Called on initialization. */
996
997 stream *
998 output_stream (void)
999 {
1000   return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
1001 }
1002
1003
1004 /* error_stream()-- Return a stream pointer to the default error stream.
1005  * Called on initialization. */
1006
1007 stream *
1008 error_stream (void)
1009 {
1010   return fd_to_stream (STDERR_FILENO, PROT_WRITE);
1011 }
1012
1013 /* init_error_stream()-- Return a pointer to the error stream.  This
1014  * subroutine is called when the stream is needed, rather than at
1015  * initialization.  We want to work even if memory has been seriously
1016  * corrupted. */
1017
1018 stream *
1019 init_error_stream (void)
1020 {
1021   static unix_stream error;
1022
1023   memset (&error, '\0', sizeof (error));
1024
1025   error.fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1026
1027   error.st.alloc_w_at = (void *) fd_alloc_w_at;
1028   error.st.sfree = (void *) fd_sfree;
1029
1030   error.unbuffered = 1;
1031   error.buffer = error.small_buffer;
1032
1033   return (stream *) & error;
1034 }
1035
1036
1037 /* compare_file_filename()-- Given an open stream and a fortran string
1038  * that is a filename, figure out if the file is the same as the
1039  * filename. */
1040
1041 int
1042 compare_file_filename (stream * s, const char *name, int len)
1043 {
1044   char path[PATH_MAX + 1];
1045   struct stat st1, st2;
1046
1047   if (unpack_filename (path, name, len))
1048     return 0;                   /* Can't be the same */
1049
1050   /* If the filename doesn't exist, then there is no match with the
1051    * existing file. */
1052
1053   if (stat (path, &st1) < 0)
1054     return 0;
1055
1056   fstat (((unix_stream *) s)->fd, &st2);
1057
1058   return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
1059 }
1060
1061
1062 /* find_file0()-- Recursive work function for find_file() */
1063
1064 static gfc_unit *
1065 find_file0 (gfc_unit * u, struct stat *st1)
1066 {
1067   struct stat st2;
1068   gfc_unit *v;
1069
1070   if (u == NULL)
1071     return NULL;
1072
1073   if (fstat (((unix_stream *) u->s)->fd, &st2) >= 0 &&
1074       st1->st_dev == st2.st_dev && st1->st_ino == st2.st_ino)
1075     return u;
1076
1077   v = find_file0 (u->left, st1);
1078   if (v != NULL)
1079     return v;
1080
1081   v = find_file0 (u->right, st1);
1082   if (v != NULL)
1083     return v;
1084
1085   return NULL;
1086 }
1087
1088
1089 /* find_file()-- Take the current filename and see if there is a unit
1090  * that has the file already open.  Returns a pointer to the unit if so. */
1091
1092 gfc_unit *
1093 find_file (void)
1094 {
1095   char path[PATH_MAX + 1];
1096   struct stat statbuf;
1097
1098   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1099     return NULL;
1100
1101   if (stat (path, &statbuf) < 0)
1102     return NULL;
1103
1104   return find_file0 (g.unit_root, &statbuf);
1105 }
1106
1107
1108 /* stream_at_bof()-- Returns nonzero if the stream is at the beginning
1109  * of the file. */
1110
1111 int
1112 stream_at_bof (stream * s)
1113 {
1114   unix_stream *us;
1115
1116   if (!is_seekable (s))
1117     return 0;
1118
1119   us = (unix_stream *) s;
1120
1121   return us->logical_offset == 0;
1122 }
1123
1124
1125 /* stream_at_eof()-- Returns nonzero if the stream is at the beginning
1126  * of the file. */
1127
1128 int
1129 stream_at_eof (stream * s)
1130 {
1131   unix_stream *us;
1132
1133   if (!is_seekable (s))
1134     return 0;
1135
1136   us = (unix_stream *) s;
1137
1138   return us->logical_offset == us->dirty_offset;
1139 }
1140
1141
1142 /* delete_file()-- Given a unit structure, delete the file associated
1143  * with the unit.  Returns nonzero if something went wrong. */
1144
1145 int
1146 delete_file (gfc_unit * u)
1147 {
1148   char path[PATH_MAX + 1];
1149
1150   if (unpack_filename (path, u->file, u->file_len))
1151     {                           /* Shouldn't be possible */
1152       errno = ENOENT;
1153       return 1;
1154     }
1155
1156   return unlink (path);
1157 }
1158
1159
1160 /* file_exists()-- Returns nonzero if the current filename exists on
1161  * the system */
1162
1163 int
1164 file_exists (void)
1165 {
1166   char path[PATH_MAX + 1];
1167   struct stat statbuf;
1168
1169   if (unpack_filename (path, ioparm.file, ioparm.file_len))
1170     return 0;
1171
1172   if (stat (path, &statbuf) < 0)
1173     return 0;
1174
1175   return 1;
1176 }
1177
1178
1179
1180 static const char *yes = "YES", *no = "NO", *unknown = "UNKNOWN";
1181
1182 /* inquire_sequential()-- Given a fortran string, determine if the
1183  * file is suitable for sequential access.  Returns a C-style
1184  * string. */
1185
1186 const char *
1187 inquire_sequential (const char *string, int len)
1188 {
1189   char path[PATH_MAX + 1];
1190   struct stat statbuf;
1191
1192   if (string == NULL ||
1193       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1194     return unknown;
1195
1196   if (S_ISREG (statbuf.st_mode) ||
1197       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1198     return yes;
1199
1200   if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1201     return no;
1202
1203   return unknown;
1204 }
1205
1206
1207 /* inquire_direct()-- Given a fortran string, determine if the file is
1208  * suitable for direct access.  Returns a C-style string. */
1209
1210 const char *
1211 inquire_direct (const char *string, int len)
1212 {
1213   char path[PATH_MAX + 1];
1214   struct stat statbuf;
1215
1216   if (string == NULL ||
1217       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1218     return unknown;
1219
1220   if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1221     return yes;
1222
1223   if (S_ISDIR (statbuf.st_mode) ||
1224       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1225     return no;
1226
1227   return unknown;
1228 }
1229
1230
1231 /* inquire_formatted()-- Given a fortran string, determine if the file
1232  * is suitable for formatted form.  Returns a C-style string. */
1233
1234 const char *
1235 inquire_formatted (const char *string, int len)
1236 {
1237   char path[PATH_MAX + 1];
1238   struct stat statbuf;
1239
1240   if (string == NULL ||
1241       unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1242     return unknown;
1243
1244   if (S_ISREG (statbuf.st_mode) ||
1245       S_ISBLK (statbuf.st_mode) ||
1246       S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1247     return yes;
1248
1249   if (S_ISDIR (statbuf.st_mode))
1250     return no;
1251
1252   return unknown;
1253 }
1254
1255
1256 /* inquire_unformatted()-- Given a fortran string, determine if the file
1257  * is suitable for unformatted form.  Returns a C-style string. */
1258
1259 const char *
1260 inquire_unformatted (const char *string, int len)
1261 {
1262   return inquire_formatted (string, len);
1263 }
1264
1265
1266 /* inquire_access()-- Given a fortran string, determine if the file is
1267  * suitable for access. */
1268
1269 static const char *
1270 inquire_access (const char *string, int len, int mode)
1271 {
1272   char path[PATH_MAX + 1];
1273
1274   if (string == NULL || unpack_filename (path, string, len) ||
1275       access (path, mode) < 0)
1276     return no;
1277
1278   return yes;
1279 }
1280
1281
1282 /* inquire_read()-- Given a fortran string, determine if the file is
1283  * suitable for READ access. */
1284
1285 const char *
1286 inquire_read (const char *string, int len)
1287 {
1288   return inquire_access (string, len, R_OK);
1289 }
1290
1291
1292 /* inquire_write()-- Given a fortran string, determine if the file is
1293  * suitable for READ access. */
1294
1295 const char *
1296 inquire_write (const char *string, int len)
1297 {
1298   return inquire_access (string, len, W_OK);
1299 }
1300
1301
1302 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1303  * suitable for read and write access. */
1304
1305 const char *
1306 inquire_readwrite (const char *string, int len)
1307 {
1308   return inquire_access (string, len, R_OK | W_OK);
1309 }
1310
1311
1312 /* file_length()-- Return the file length in bytes, -1 if unknown */
1313
1314 gfc_offset
1315 file_length (stream * s)
1316 {
1317   return ((unix_stream *) s)->file_length;
1318 }
1319
1320
1321 /* file_position()-- Return the current position of the file */
1322
1323 gfc_offset
1324 file_position (stream * s)
1325 {
1326   return ((unix_stream *) s)->logical_offset;
1327 }
1328
1329
1330 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1331  * it is not */
1332
1333 int
1334 is_seekable (stream * s)
1335 {
1336   /* by convention, if file_length == -1, the file is not seekable
1337      note that a mmapped file is always seekable, an fd_ file may
1338      or may not be. */
1339   return ((unix_stream *) s)->file_length!=-1;
1340 }
1341
1342 try
1343 flush (stream *s)
1344 {
1345   return fd_flush( (unix_stream *) s);
1346 }
1347
1348 int
1349 stream_isatty (stream *s)
1350 {
1351   return isatty (((unix_stream *) s)->fd);
1352 }
1353
1354 char *
1355 stream_ttyname (stream *s)
1356 {
1357 #ifdef HAVE_TTYNAME
1358   return ttyname (((unix_stream *) s)->fd);
1359 #else
1360   return NULL;
1361 #endif
1362 }
1363
1364
1365 /* How files are stored:  This is an operating-system specific issue,
1366    and therefore belongs here.  There are three cases to consider.
1367
1368    Direct Access:
1369       Records are written as block of bytes corresponding to the record
1370       length of the file.  This goes for both formatted and unformatted
1371       records.  Positioning is done explicitly for each data transfer,
1372       so positioning is not much of an issue.
1373
1374    Sequential Formatted:
1375       Records are separated by newline characters.  The newline character
1376       is prohibited from appearing in a string.  If it does, this will be
1377       messed up on the next read.  End of file is also the end of a record.
1378
1379    Sequential Unformatted:
1380       In this case, we are merely copying bytes to and from main storage,
1381       yet we need to keep track of varying record lengths.  We adopt
1382       the solution used by f2c.  Each record contains a pair of length
1383       markers:
1384
1385         Length of record n in bytes
1386         Data of record n
1387         Length of record n in bytes
1388
1389         Length of record n+1 in bytes
1390         Data of record n+1
1391         Length of record n+1 in bytes
1392
1393      The length is stored at the end of a record to allow backspacing to the
1394      previous record.  Between data transfer statements, the file pointer
1395      is left pointing to the first length of the current record.
1396
1397      ENDFILE records are never explicitly stored.
1398
1399 */