OSDN Git Service

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