OSDN Git Service

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