OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [io/] [unix.c] - Blame information for rev 867

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2
   2011
3
   Free Software Foundation, Inc.
4
   Contributed by Andy Vaught
5
   F2003 I/O support contributed by Jerry DeLisle
6
 
7
This file is part of the GNU Fortran runtime library (libgfortran).
8
 
9
Libgfortran is free software; you can redistribute it and/or modify
10
it under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 3, or (at your option)
12
any later version.
13
 
14
Libgfortran is distributed in the hope that it will be useful,
15
but WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17
GNU General Public License for more details.
18
 
19
Under Section 7 of GPL version 3, you are granted additional
20
permissions described in the GCC Runtime Library Exception, version
21
3.1, as published by the Free Software Foundation.
22
 
23
You should have received a copy of the GNU General Public License and
24
a copy of the GCC Runtime Library Exception along with this program;
25
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
26
<http://www.gnu.org/licenses/>.  */
27
 
28
/* Unix stream I/O module */
29
 
30
#include "io.h"
31
#include "unix.h"
32
#include <stdlib.h>
33
#include <limits.h>
34
 
35
#include <unistd.h>
36
#include <sys/stat.h>
37
#include <fcntl.h>
38
#include <assert.h>
39
 
40
#include <string.h>
41
#include <errno.h>
42
 
43
 
44
/* min macro that evaluates its arguments only once.  */
45
#define min(a,b)                \
46
  ({ typeof (a) _a = (a);       \
47
    typeof (b) _b = (b);        \
48
    _a < _b ? _a : _b; })
49
 
50
 
51
/* For mingw, we don't identify files by their inode number, but by a
52
   64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
53
#ifdef __MINGW32__
54
 
55
#define WIN32_LEAN_AND_MEAN
56
#include <windows.h>
57
 
58
#if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
59
#undef lseek
60
#define lseek _lseeki64
61
#undef fstat
62
#define fstat _fstati64
63
#undef stat
64
#define stat _stati64
65
#endif
66
 
67
#ifndef HAVE_WORKING_STAT
68
static uint64_t
69
id_from_handle (HANDLE hFile)
70
{
71
  BY_HANDLE_FILE_INFORMATION FileInformation;
72
 
73
  if (hFile == INVALID_HANDLE_VALUE)
74
      return 0;
75
 
76
  memset (&FileInformation, 0, sizeof(FileInformation));
77
  if (!GetFileInformationByHandle (hFile, &FileInformation))
78
    return 0;
79
 
80
  return ((uint64_t) FileInformation.nFileIndexLow)
81
         | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
82
}
83
 
84
 
85
static uint64_t
86
id_from_path (const char *path)
87
{
88
  HANDLE hFile;
89
  uint64_t res;
90
 
91
  if (!path || !*path || access (path, F_OK))
92
    return (uint64_t) -1;
93
 
94
  hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
95
                      FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
96
                      NULL);
97
  res = id_from_handle (hFile);
98
  CloseHandle (hFile);
99
  return res;
100
}
101
 
102
 
103
static uint64_t
104
id_from_fd (const int fd)
105
{
106
  return id_from_handle ((HANDLE) _get_osfhandle (fd));
107
}
108
 
109
#endif
110
#endif
111
 
112
#ifndef PATH_MAX
113
#define PATH_MAX 1024
114
#endif
115
 
116
/* These flags aren't defined on all targets (mingw32), so provide them
117
   here.  */
118
#ifndef S_IRGRP
119
#define S_IRGRP 0
120
#endif
121
 
122
#ifndef S_IWGRP
123
#define S_IWGRP 0
124
#endif
125
 
126
#ifndef S_IROTH
127
#define S_IROTH 0
128
#endif
129
 
130
#ifndef S_IWOTH
131
#define S_IWOTH 0
132
#endif
133
 
134
 
135
#ifndef HAVE_ACCESS
136
 
137
#ifndef W_OK
138
#define W_OK 2
139
#endif
140
 
141
#ifndef R_OK
142
#define R_OK 4
143
#endif
144
 
145
#ifndef F_OK
146
#define F_OK 0
147
#endif
148
 
149
/* Fallback implementation of access() on systems that don't have it.
150
   Only modes R_OK, W_OK and F_OK are used in this file.  */
151
 
152
static int
153
fallback_access (const char *path, int mode)
154
{
155
  int fd;
156
 
157
  if ((mode & R_OK) && (fd = open (path, O_RDONLY)) < 0)
158
    return -1;
159
  close (fd);
160
 
161
  if ((mode & W_OK) && (fd = open (path, O_WRONLY)) < 0)
162
    return -1;
163
  close (fd);
164
 
165
  if (mode == F_OK)
166
    {
167
      struct stat st;
168
      return stat (path, &st);
169
    }
170
 
171
  return 0;
172
}
173
 
174
#undef access
175
#define access fallback_access
176
#endif
177
 
178
 
179
/* Unix and internal stream I/O module */
180
 
181
static const int BUFFER_SIZE = 8192;
182
 
183
typedef struct
184
{
185
  stream st;
186
 
187
  gfc_offset buffer_offset;     /* File offset of the start of the buffer */
188
  gfc_offset physical_offset;   /* Current physical file offset */
189
  gfc_offset logical_offset;    /* Current logical file offset */
190
  gfc_offset file_length;       /* Length of the file. */
191
 
192
  char *buffer;                 /* Pointer to the buffer.  */
193
  int fd;                       /* The POSIX file descriptor.  */
194
 
195
  int active;                   /* Length of valid bytes in the buffer */
196
 
197
  int ndirty;                   /* Dirty bytes starting at buffer_offset */
198
 
199
  /* Cached stat(2) values.  */
200
  dev_t st_dev;
201
  ino_t st_ino;
202
}
203
unix_stream;
204
 
205
 
206
/* fix_fd()-- Given a file descriptor, make sure it is not one of the
207
 * standard descriptors, returning a non-standard descriptor.  If the
208
 * user specifies that system errors should go to standard output,
209
 * then closes standard output, we don't want the system errors to a
210
 * file that has been given file descriptor 1 or 0.  We want to send
211
 * the error to the invalid descriptor. */
212
 
213
static int
214
fix_fd (int fd)
215
{
216
#ifdef HAVE_DUP
217
  int input, output, error;
218
 
219
  input = output = error = 0;
220
 
221
  /* Unix allocates the lowest descriptors first, so a loop is not
222
     required, but this order is. */
223
  if (fd == STDIN_FILENO)
224
    {
225
      fd = dup (fd);
226
      input = 1;
227
    }
228
  if (fd == STDOUT_FILENO)
229
    {
230
      fd = dup (fd);
231
      output = 1;
232
    }
233
  if (fd == STDERR_FILENO)
234
    {
235
      fd = dup (fd);
236
      error = 1;
237
    }
238
 
239
  if (input)
240
    close (STDIN_FILENO);
241
  if (output)
242
    close (STDOUT_FILENO);
243
  if (error)
244
    close (STDERR_FILENO);
245
#endif
246
 
247
  return fd;
248
}
249
 
250
 
251
/* If the stream corresponds to a preconnected unit, we flush the
252
   corresponding C stream.  This is bugware for mixed C-Fortran codes
253
   where the C code doesn't flush I/O before returning.  */
254
void
255
flush_if_preconnected (stream * s)
256
{
257
  int fd;
258
 
259
  fd = ((unix_stream *) s)->fd;
260
  if (fd == STDIN_FILENO)
261
    fflush (stdin);
262
  else if (fd == STDOUT_FILENO)
263
    fflush (stdout);
264
  else if (fd == STDERR_FILENO)
265
    fflush (stderr);
266
}
267
 
268
 
269
/********************************************************************
270
Raw I/O functions (read, write, seek, tell, truncate, close).
271
 
272
These functions wrap the basic POSIX I/O syscalls. Any deviation in
273
semantics is a bug, except the following: write restarts in case
274
of being interrupted by a signal, and as the first argument the
275
functions take the unix_stream struct rather than an integer file
276
descriptor. Also, for POSIX read() and write() a nbyte argument larger
277
than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
278
than size_t as for POSIX read/write.
279
*********************************************************************/
280
 
281
static int
282
raw_flush (unix_stream * s  __attribute__ ((unused)))
283
{
284
  return 0;
285
}
286
 
287
static ssize_t
288
raw_read (unix_stream * s, void * buf, ssize_t nbyte)
289
{
290
  /* For read we can't do I/O in a loop like raw_write does, because
291
     that will break applications that wait for interactive I/O.  */
292
  return read (s->fd, buf, nbyte);
293
}
294
 
295
static ssize_t
296
raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
297
{
298
  ssize_t trans, bytes_left;
299
  char *buf_st;
300
 
301
  bytes_left = nbyte;
302
  buf_st = (char *) buf;
303
 
304
  /* We must write in a loop since some systems don't restart system
305
     calls in case of a signal.  */
306
  while (bytes_left > 0)
307
    {
308
      trans = write (s->fd, buf_st, bytes_left);
309
      if (trans < 0)
310
        {
311
          if (errno == EINTR)
312
            continue;
313
          else
314
            return trans;
315
        }
316
      buf_st += trans;
317
      bytes_left -= trans;
318
    }
319
 
320
  return nbyte - bytes_left;
321
}
322
 
323
static gfc_offset
324
raw_seek (unix_stream * s, gfc_offset offset, int whence)
325
{
326
  return lseek (s->fd, offset, whence);
327
}
328
 
329
static gfc_offset
330
raw_tell (unix_stream * s)
331
{
332
  return lseek (s->fd, 0, SEEK_CUR);
333
}
334
 
335
static gfc_offset
336
raw_size (unix_stream * s)
337
{
338
  struct stat statbuf;
339
  int ret = fstat (s->fd, &statbuf);
340
  if (ret == -1)
341
    return ret;
342
  return statbuf.st_size;
343
}
344
 
345
static int
346
raw_truncate (unix_stream * s, gfc_offset length)
347
{
348
#ifdef __MINGW32__
349
  HANDLE h;
350
  gfc_offset cur;
351
 
352
  if (isatty (s->fd))
353
    {
354
      errno = EBADF;
355
      return -1;
356
    }
357
  h = (HANDLE) _get_osfhandle (s->fd);
358
  if (h == INVALID_HANDLE_VALUE)
359
    {
360
      errno = EBADF;
361
      return -1;
362
    }
363
  cur = lseek (s->fd, 0, SEEK_CUR);
364
  if (cur == -1)
365
    return -1;
366
  if (lseek (s->fd, length, SEEK_SET) == -1)
367
    goto error;
368
  if (!SetEndOfFile (h))
369
    {
370
      errno = EBADF;
371
      goto error;
372
    }
373
  if (lseek (s->fd, cur, SEEK_SET) == -1)
374
    return -1;
375
  return 0;
376
 error:
377
  lseek (s->fd, cur, SEEK_SET);
378
  return -1;
379
#elif defined HAVE_FTRUNCATE
380
  return ftruncate (s->fd, length);
381
#elif defined HAVE_CHSIZE
382
  return chsize (s->fd, length);
383
#else
384
  runtime_error ("required ftruncate or chsize support not present");
385
  return -1;
386
#endif
387
}
388
 
389
static int
390
raw_close (unix_stream * s)
391
{
392
  int retval;
393
 
394
  if (s->fd != STDOUT_FILENO
395
      && s->fd != STDERR_FILENO
396
      && s->fd != STDIN_FILENO)
397
    retval = close (s->fd);
398
  else
399
    retval = 0;
400
  free (s);
401
  return retval;
402
}
403
 
404
static int
405
raw_init (unix_stream * s)
406
{
407
  s->st.read = (void *) raw_read;
408
  s->st.write = (void *) raw_write;
409
  s->st.seek = (void *) raw_seek;
410
  s->st.tell = (void *) raw_tell;
411
  s->st.size = (void *) raw_size;
412
  s->st.trunc = (void *) raw_truncate;
413
  s->st.close = (void *) raw_close;
414
  s->st.flush = (void *) raw_flush;
415
 
416
  s->buffer = NULL;
417
  return 0;
418
}
419
 
420
 
421
/*********************************************************************
422
Buffered I/O functions. These functions have the same semantics as the
423
raw I/O functions above, except that they are buffered in order to
424
improve performance. The buffer must be flushed when switching from
425
reading to writing and vice versa. Only supported for regular files.
426
*********************************************************************/
427
 
428
static int
429
buf_flush (unix_stream * s)
430
{
431
  int writelen;
432
 
433
  /* Flushing in read mode means discarding read bytes.  */
434
  s->active = 0;
435
 
436
  if (s->ndirty == 0)
437
    return 0;
438
 
439
  if (s->physical_offset != s->buffer_offset
440
      && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
441
    return -1;
442
 
443
  writelen = raw_write (s, s->buffer, s->ndirty);
444
 
445
  s->physical_offset = s->buffer_offset + writelen;
446
 
447
  if (s->physical_offset > s->file_length)
448
      s->file_length = s->physical_offset;
449
 
450
  s->ndirty -= writelen;
451
  if (s->ndirty != 0)
452
    return -1;
453
 
454
  return 0;
455
}
456
 
457
static ssize_t
458
buf_read (unix_stream * s, void * buf, ssize_t nbyte)
459
{
460
  if (s->active == 0)
461
    s->buffer_offset = s->logical_offset;
462
 
463
  /* Is the data we want in the buffer?  */
464
  if (s->logical_offset + nbyte <= s->buffer_offset + s->active
465
      && s->buffer_offset <= s->logical_offset)
466
    memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
467
  else
468
    {
469
      /* First copy the active bytes if applicable, then read the rest
470
         either directly or filling the buffer.  */
471
      char *p;
472
      int nread = 0;
473
      ssize_t to_read, did_read;
474
      gfc_offset new_logical;
475
 
476
      p = (char *) buf;
477
      if (s->logical_offset >= s->buffer_offset
478
          && s->buffer_offset + s->active >= s->logical_offset)
479
        {
480
          nread = s->active - (s->logical_offset - s->buffer_offset);
481
          memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
482
                  nread);
483
          p += nread;
484
        }
485
      /* At this point we consider all bytes in the buffer discarded.  */
486
      to_read = nbyte - nread;
487
      new_logical = s->logical_offset + nread;
488
      if (s->physical_offset != new_logical
489
          && lseek (s->fd, new_logical, SEEK_SET) < 0)
490
        return -1;
491
      s->buffer_offset = s->physical_offset = new_logical;
492
      if (to_read <= BUFFER_SIZE/2)
493
        {
494
          did_read = raw_read (s, s->buffer, BUFFER_SIZE);
495
          s->physical_offset += did_read;
496
          s->active = did_read;
497
          did_read = (did_read > to_read) ? to_read : did_read;
498
          memcpy (p, s->buffer, did_read);
499
        }
500
      else
501
        {
502
          did_read = raw_read (s, p, to_read);
503
          s->physical_offset += did_read;
504
          s->active = 0;
505
        }
506
      nbyte = did_read + nread;
507
    }
508
  s->logical_offset += nbyte;
509
  return nbyte;
510
}
511
 
512
static ssize_t
513
buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
514
{
515
  if (s->ndirty == 0)
516
    s->buffer_offset = s->logical_offset;
517
 
518
  /* Does the data fit into the buffer?  As a special case, if the
519
     buffer is empty and the request is bigger than BUFFER_SIZE/2,
520
     write directly. This avoids the case where the buffer would have
521
     to be flushed at every write.  */
522
  if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
523
      && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
524
      && s->buffer_offset <= s->logical_offset
525
      && s->buffer_offset + s->ndirty >= s->logical_offset)
526
    {
527
      memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
528
      int nd = (s->logical_offset - s->buffer_offset) + nbyte;
529
      if (nd > s->ndirty)
530
        s->ndirty = nd;
531
    }
532
  else
533
    {
534
      /* Flush, and either fill the buffer with the new data, or if
535
         the request is bigger than the buffer size, write directly
536
         bypassing the buffer.  */
537
      buf_flush (s);
538
      if (nbyte <= BUFFER_SIZE/2)
539
        {
540
          memcpy (s->buffer, buf, nbyte);
541
          s->buffer_offset = s->logical_offset;
542
          s->ndirty += nbyte;
543
        }
544
      else
545
        {
546
          if (s->physical_offset != s->logical_offset)
547
            {
548
              if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
549
                return -1;
550
              s->physical_offset = s->logical_offset;
551
            }
552
 
553
          nbyte = raw_write (s, buf, nbyte);
554
          s->physical_offset += nbyte;
555
        }
556
    }
557
  s->logical_offset += nbyte;
558
  if (s->logical_offset > s->file_length)
559
    s->file_length = s->logical_offset;
560
  return nbyte;
561
}
562
 
563
static gfc_offset
564
buf_seek (unix_stream * s, gfc_offset offset, int whence)
565
{
566
  switch (whence)
567
    {
568
    case SEEK_SET:
569
      break;
570
    case SEEK_CUR:
571
      offset += s->logical_offset;
572
      break;
573
    case SEEK_END:
574
      offset += s->file_length;
575
      break;
576
    default:
577
      return -1;
578
    }
579
  if (offset < 0)
580
    {
581
      errno = EINVAL;
582
      return -1;
583
    }
584
  s->logical_offset = offset;
585
  return offset;
586
}
587
 
588
static gfc_offset
589
buf_tell (unix_stream * s)
590
{
591
  return buf_seek (s, 0, SEEK_CUR);
592
}
593
 
594
static gfc_offset
595
buf_size (unix_stream * s)
596
{
597
  return s->file_length;
598
}
599
 
600
static int
601
buf_truncate (unix_stream * s, gfc_offset length)
602
{
603
  int r;
604
 
605
  if (buf_flush (s) != 0)
606
    return -1;
607
  r = raw_truncate (s, length);
608
  if (r == 0)
609
    s->file_length = length;
610
  return r;
611
}
612
 
613
static int
614
buf_close (unix_stream * s)
615
{
616
  if (buf_flush (s) != 0)
617
    return -1;
618
  free (s->buffer);
619
  return raw_close (s);
620
}
621
 
622
static int
623
buf_init (unix_stream * s)
624
{
625
  s->st.read = (void *) buf_read;
626
  s->st.write = (void *) buf_write;
627
  s->st.seek = (void *) buf_seek;
628
  s->st.tell = (void *) buf_tell;
629
  s->st.size = (void *) buf_size;
630
  s->st.trunc = (void *) buf_truncate;
631
  s->st.close = (void *) buf_close;
632
  s->st.flush = (void *) buf_flush;
633
 
634
  s->buffer = get_mem (BUFFER_SIZE);
635
  return 0;
636
}
637
 
638
 
639
/*********************************************************************
640
  memory stream functions - These are used for internal files
641
 
642
  The idea here is that a single stream structure is created and all
643
  requests must be satisfied from it.  The location and size of the
644
  buffer is the character variable supplied to the READ or WRITE
645
  statement.
646
 
647
*********************************************************************/
648
 
649
char *
650
mem_alloc_r (stream * strm, int * len)
651
{
652
  unix_stream * s = (unix_stream *) strm;
653
  gfc_offset n;
654
  gfc_offset where = s->logical_offset;
655
 
656
  if (where < s->buffer_offset || where > s->buffer_offset + s->active)
657
    return NULL;
658
 
659
  n = s->buffer_offset + s->active - where;
660
  if (*len > n)
661
    *len = n;
662
 
663
  s->logical_offset = where + *len;
664
 
665
  return s->buffer + (where - s->buffer_offset);
666
}
667
 
668
 
669
char *
670
mem_alloc_r4 (stream * strm, int * len)
671
{
672
  unix_stream * s = (unix_stream *) strm;
673
  gfc_offset n;
674
  gfc_offset where = s->logical_offset;
675
 
676
  if (where < s->buffer_offset || where > s->buffer_offset + s->active)
677
    return NULL;
678
 
679
  n = s->buffer_offset + s->active - where;
680
  if (*len > n)
681
    *len = n;
682
 
683
  s->logical_offset = where + *len;
684
 
685
  return s->buffer + (where - s->buffer_offset) * 4;
686
}
687
 
688
 
689
char *
690
mem_alloc_w (stream * strm, int * len)
691
{
692
  unix_stream * s = (unix_stream *) strm;
693
  gfc_offset m;
694
  gfc_offset where = s->logical_offset;
695
 
696
  m = where + *len;
697
 
698
  if (where < s->buffer_offset)
699
    return NULL;
700
 
701
  if (m > s->file_length)
702
    return NULL;
703
 
704
  s->logical_offset = m;
705
 
706
  return s->buffer + (where - s->buffer_offset);
707
}
708
 
709
 
710
gfc_char4_t *
711
mem_alloc_w4 (stream * strm, int * len)
712
{
713
  unix_stream * s = (unix_stream *) strm;
714
  gfc_offset m;
715
  gfc_offset where = s->logical_offset;
716
  gfc_char4_t *result = (gfc_char4_t *) s->buffer;
717
 
718
  m = where + *len;
719
 
720
  if (where < s->buffer_offset)
721
    return NULL;
722
 
723
  if (m > s->file_length)
724
    return NULL;
725
 
726
  s->logical_offset = m;
727
  return &result[where - s->buffer_offset];
728
}
729
 
730
 
731
/* Stream read function for character(kine=1) internal units.  */
732
 
733
static ssize_t
734
mem_read (stream * s, void * buf, ssize_t nbytes)
735
{
736
  void *p;
737
  int nb = nbytes;
738
 
739
  p = mem_alloc_r (s, &nb);
740
  if (p)
741
    {
742
      memcpy (buf, p, nb);
743
      return (ssize_t) nb;
744
    }
745
  else
746
    return 0;
747
}
748
 
749
 
750
/* Stream read function for chracter(kind=4) internal units.  */
751
 
752
static ssize_t
753
mem_read4 (stream * s, void * buf, ssize_t nbytes)
754
{
755
  void *p;
756
  int nb = nbytes;
757
 
758
  p = mem_alloc_r (s, &nb);
759
  if (p)
760
    {
761
      memcpy (buf, p, nb);
762
      return (ssize_t) nb;
763
    }
764
  else
765
    return 0;
766
}
767
 
768
 
769
/* Stream write function for character(kind=1) internal units.  */
770
 
771
static ssize_t
772
mem_write (stream * s, const void * buf, ssize_t nbytes)
773
{
774
  void *p;
775
  int nb = nbytes;
776
 
777
  p = mem_alloc_w (s, &nb);
778
  if (p)
779
    {
780
      memcpy (p, buf, nb);
781
      return (ssize_t) nb;
782
    }
783
  else
784
    return 0;
785
}
786
 
787
 
788
/* Stream write function for character(kind=4) internal units.  */
789
 
790
static ssize_t
791
mem_write4 (stream * s, const void * buf, ssize_t nwords)
792
{
793
  gfc_char4_t *p;
794
  int nw = nwords;
795
 
796
  p = mem_alloc_w4 (s, &nw);
797
  if (p)
798
    {
799
      while (nw--)
800
        *p++ = (gfc_char4_t) *((char *) buf);
801
      return nwords;
802
    }
803
  else
804
    return 0;
805
}
806
 
807
 
808
static gfc_offset
809
mem_seek (stream * strm, gfc_offset offset, int whence)
810
{
811
  unix_stream * s = (unix_stream *) strm;
812
  switch (whence)
813
    {
814
    case SEEK_SET:
815
      break;
816
    case SEEK_CUR:
817
      offset += s->logical_offset;
818
      break;
819
    case SEEK_END:
820
      offset += s->file_length;
821
      break;
822
    default:
823
      return -1;
824
    }
825
 
826
  /* Note that for internal array I/O it's actually possible to have a
827
     negative offset, so don't check for that.  */
828
  if (offset > s->file_length)
829
    {
830
      errno = EINVAL;
831
      return -1;
832
    }
833
 
834
  s->logical_offset = offset;
835
 
836
  /* Returning < 0 is the error indicator for sseek(), so return 0 if
837
     offset is negative.  Thus if the return value is 0, the caller
838
     has to use stell() to get the real value of logical_offset.  */
839
  if (offset >= 0)
840
    return offset;
841
  return 0;
842
}
843
 
844
 
845
static gfc_offset
846
mem_tell (stream * s)
847
{
848
  return ((unix_stream *)s)->logical_offset;
849
}
850
 
851
 
852
static int
853
mem_truncate (unix_stream * s __attribute__ ((unused)),
854
              gfc_offset length __attribute__ ((unused)))
855
{
856
  return 0;
857
}
858
 
859
 
860
static int
861
mem_flush (unix_stream * s __attribute__ ((unused)))
862
{
863
  return 0;
864
}
865
 
866
 
867
static int
868
mem_close (unix_stream * s)
869
{
870
  free (s);
871
 
872
  return 0;
873
}
874
 
875
 
876
/*********************************************************************
877
  Public functions -- A reimplementation of this module needs to
878
  define functional equivalents of the following.
879
*********************************************************************/
880
 
881
/* open_internal()-- Returns a stream structure from a character(kind=1)
882
   internal file */
883
 
884
stream *
885
open_internal (char *base, int length, gfc_offset offset)
886
{
887
  unix_stream *s;
888
 
889
  s = get_mem (sizeof (unix_stream));
890
  memset (s, '\0', sizeof (unix_stream));
891
 
892
  s->buffer = base;
893
  s->buffer_offset = offset;
894
 
895
  s->logical_offset = 0;
896
  s->active = s->file_length = length;
897
 
898
  s->st.close = (void *) mem_close;
899
  s->st.seek = (void *) mem_seek;
900
  s->st.tell = (void *) mem_tell;
901
  /* buf_size is not a typo, we just reuse an identical
902
     implementation.  */
903
  s->st.size = (void *) buf_size;
904
  s->st.trunc = (void *) mem_truncate;
905
  s->st.read = (void *) mem_read;
906
  s->st.write = (void *) mem_write;
907
  s->st.flush = (void *) mem_flush;
908
 
909
  return (stream *) s;
910
}
911
 
912
/* open_internal4()-- Returns a stream structure from a character(kind=4)
913
   internal file */
914
 
915
stream *
916
open_internal4 (char *base, int length, gfc_offset offset)
917
{
918
  unix_stream *s;
919
 
920
  s = get_mem (sizeof (unix_stream));
921
  memset (s, '\0', sizeof (unix_stream));
922
 
923
  s->buffer = base;
924
  s->buffer_offset = offset;
925
 
926
  s->logical_offset = 0;
927
  s->active = s->file_length = length;
928
 
929
  s->st.close = (void *) mem_close;
930
  s->st.seek = (void *) mem_seek;
931
  s->st.tell = (void *) mem_tell;
932
  /* buf_size is not a typo, we just reuse an identical
933
     implementation.  */
934
  s->st.size = (void *) buf_size;
935
  s->st.trunc = (void *) mem_truncate;
936
  s->st.read = (void *) mem_read4;
937
  s->st.write = (void *) mem_write4;
938
  s->st.flush = (void *) mem_flush;
939
 
940
  return (stream *) s;
941
}
942
 
943
 
944
/* fd_to_stream()-- Given an open file descriptor, build a stream
945
 * around it. */
946
 
947
static stream *
948
fd_to_stream (int fd)
949
{
950
  struct stat statbuf;
951
  unix_stream *s;
952
 
953
  s = get_mem (sizeof (unix_stream));
954
  memset (s, '\0', sizeof (unix_stream));
955
 
956
  s->fd = fd;
957
  s->buffer_offset = 0;
958
  s->physical_offset = 0;
959
  s->logical_offset = 0;
960
 
961
  /* Get the current length of the file. */
962
 
963
  fstat (fd, &statbuf);
964
 
965
  s->st_dev = statbuf.st_dev;
966
  s->st_ino = statbuf.st_ino;
967
  s->file_length = statbuf.st_size;
968
 
969
  /* Only use buffered IO for regular files.  */
970
  if (S_ISREG (statbuf.st_mode)
971
      && !options.all_unbuffered
972
      && !(options.unbuffered_preconnected &&
973
           (s->fd == STDIN_FILENO
974
            || s->fd == STDOUT_FILENO
975
            || s->fd == STDERR_FILENO)))
976
    buf_init (s);
977
  else
978
    raw_init (s);
979
 
980
  return (stream *) s;
981
}
982
 
983
 
984
/* Given the Fortran unit number, convert it to a C file descriptor.  */
985
 
986
int
987
unit_to_fd (int unit)
988
{
989
  gfc_unit *us;
990
  int fd;
991
 
992
  us = find_unit (unit);
993
  if (us == NULL)
994
    return -1;
995
 
996
  fd = ((unix_stream *) us->s)->fd;
997
  unlock_unit (us);
998
  return fd;
999
}
1000
 
1001
 
1002
/* unpack_filename()-- Given a fortran string and a pointer to a
1003
 * buffer that is PATH_MAX characters, convert the fortran string to a
1004
 * C string in the buffer.  Returns nonzero if this is not possible.  */
1005
 
1006
int
1007
unpack_filename (char *cstring, const char *fstring, int len)
1008
{
1009
  if (fstring == NULL)
1010
    return EFAULT;
1011
  len = fstrlen (fstring, len);
1012
  if (len >= PATH_MAX)
1013
    return ENAMETOOLONG;
1014
 
1015
  memmove (cstring, fstring, len);
1016
  cstring[len] = '\0';
1017
 
1018
  return 0;
1019
}
1020
 
1021
 
1022
/* tempfile()-- Generate a temporary filename for a scratch file and
1023
 * open it.  mkstemp() opens the file for reading and writing, but the
1024
 * library mode prevents anything that is not allowed.  The descriptor
1025
 * is returned, which is -1 on error.  The template is pointed to by
1026
 * opp->file, which is copied into the unit structure
1027
 * and freed later. */
1028
 
1029
static int
1030
tempfile (st_parameter_open *opp)
1031
{
1032
  const char *tempdir;
1033
  char *template;
1034
  const char *slash = "/";
1035
  int fd;
1036
  size_t tempdirlen;
1037
 
1038
#ifndef HAVE_MKSTEMP
1039
  int count;
1040
  size_t slashlen;
1041
#endif
1042
 
1043
  tempdir = getenv ("GFORTRAN_TMPDIR");
1044
#ifdef __MINGW32__
1045
  if (tempdir == NULL)
1046
    {
1047
      char buffer[MAX_PATH + 1];
1048
      DWORD ret;
1049
      ret = GetTempPath (MAX_PATH, buffer);
1050
      /* If we are not able to get a temp-directory, we use
1051
         current directory.  */
1052
      if (ret > MAX_PATH || !ret)
1053
        buffer[0] = 0;
1054
      else
1055
        buffer[ret] = 0;
1056
      tempdir = strdup (buffer);
1057
    }
1058
#else
1059
  if (tempdir == NULL)
1060
    tempdir = getenv ("TMP");
1061
  if (tempdir == NULL)
1062
    tempdir = getenv ("TEMP");
1063
  if (tempdir == NULL)
1064
    tempdir = DEFAULT_TEMPDIR;
1065
#endif
1066
 
1067
  /* Check for special case that tempdir contains slash
1068
     or backslash at end.  */
1069
  tempdirlen = strlen (tempdir);
1070
  if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1071
#ifdef __MINGW32__
1072
      || tempdir[tempdirlen - 1] == '\\'
1073
#endif
1074
     )
1075
    slash = "";
1076
 
1077
  // Take care that the template is longer in the mktemp() branch.
1078
  template = get_mem (tempdirlen + 23);
1079
 
1080
#ifdef HAVE_MKSTEMP
1081
  snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1082
            tempdir, slash);
1083
 
1084
  fd = mkstemp (template);
1085
 
1086
#else /* HAVE_MKSTEMP */
1087
  fd = -1;
1088
  count = 0;
1089
  slashlen = strlen (slash);
1090
  do
1091
    {
1092
      snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1093
                tempdir, slash);
1094
      if (count > 0)
1095
        {
1096
          int c = count;
1097
          template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1098
          c /= 26;
1099
          template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1100
          c /= 26;
1101
          template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1102
          if (c >= 26)
1103
            break;
1104
        }
1105
 
1106
      if (!mktemp (template))
1107
      {
1108
        errno = EEXIST;
1109
        count++;
1110
        continue;
1111
      }
1112
 
1113
#if defined(HAVE_CRLF) && defined(O_BINARY)
1114
      fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1115
                 S_IRUSR | S_IWUSR);
1116
#else
1117
      fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR);
1118
#endif
1119
    }
1120
  while (fd == -1 && errno == EEXIST);
1121
#endif /* HAVE_MKSTEMP */
1122
 
1123
  opp->file = template;
1124
  opp->file_len = strlen (template);    /* Don't include trailing nul */
1125
 
1126
  return fd;
1127
}
1128
 
1129
 
1130
/* regular_file()-- Open a regular file.
1131
 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1132
 * unless an error occurs.
1133
 * Returns the descriptor, which is less than zero on error. */
1134
 
1135
static int
1136
regular_file (st_parameter_open *opp, unit_flags *flags)
1137
{
1138
  char path[min(PATH_MAX, opp->file_len + 1)];
1139
  int mode;
1140
  int rwflag;
1141
  int crflag;
1142
  int fd;
1143
  int err;
1144
 
1145
  err = unpack_filename (path, opp->file, opp->file_len);
1146
  if (err)
1147
    {
1148
      errno = err;              /* Fake an OS error */
1149
      return -1;
1150
    }
1151
 
1152
#ifdef __CYGWIN__
1153
  if (opp->file_len == 7)
1154
    {
1155
      if (strncmp (path, "CONOUT$", 7) == 0
1156
          || strncmp (path, "CONERR$", 7) == 0)
1157
        {
1158
          fd = open ("/dev/conout", O_WRONLY);
1159
          flags->action = ACTION_WRITE;
1160
          return fd;
1161
        }
1162
    }
1163
 
1164
  if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1165
    {
1166
      fd = open ("/dev/conin", O_RDONLY);
1167
      flags->action = ACTION_READ;
1168
      return fd;
1169
    }
1170
#endif
1171
 
1172
 
1173
#ifdef __MINGW32__
1174
  if (opp->file_len == 7)
1175
    {
1176
      if (strncmp (path, "CONOUT$", 7) == 0
1177
          || strncmp (path, "CONERR$", 7) == 0)
1178
        {
1179
          fd = open ("CONOUT$", O_WRONLY);
1180
          flags->action = ACTION_WRITE;
1181
          return fd;
1182
        }
1183
    }
1184
 
1185
  if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1186
    {
1187
      fd = open ("CONIN$", O_RDONLY);
1188
      flags->action = ACTION_READ;
1189
      return fd;
1190
    }
1191
#endif
1192
 
1193
  rwflag = 0;
1194
 
1195
  switch (flags->action)
1196
    {
1197
    case ACTION_READ:
1198
      rwflag = O_RDONLY;
1199
      break;
1200
 
1201
    case ACTION_WRITE:
1202
      rwflag = O_WRONLY;
1203
      break;
1204
 
1205
    case ACTION_READWRITE:
1206
    case ACTION_UNSPECIFIED:
1207
      rwflag = O_RDWR;
1208
      break;
1209
 
1210
    default:
1211
      internal_error (&opp->common, "regular_file(): Bad action");
1212
    }
1213
 
1214
  switch (flags->status)
1215
    {
1216
    case STATUS_NEW:
1217
      crflag = O_CREAT | O_EXCL;
1218
      break;
1219
 
1220
    case STATUS_OLD:            /* open will fail if the file does not exist*/
1221
      crflag = 0;
1222
      break;
1223
 
1224
    case STATUS_UNKNOWN:
1225
    case STATUS_SCRATCH:
1226
      crflag = O_CREAT;
1227
      break;
1228
 
1229
    case STATUS_REPLACE:
1230
      crflag = O_CREAT | O_TRUNC;
1231
      break;
1232
 
1233
    default:
1234
      internal_error (&opp->common, "regular_file(): Bad status");
1235
    }
1236
 
1237
  /* rwflag |= O_LARGEFILE; */
1238
 
1239
#if defined(HAVE_CRLF) && defined(O_BINARY)
1240
  crflag |= O_BINARY;
1241
#endif
1242
 
1243
  mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1244
  fd = open (path, rwflag | crflag, mode);
1245
  if (flags->action != ACTION_UNSPECIFIED)
1246
    return fd;
1247
 
1248
  if (fd >= 0)
1249
    {
1250
      flags->action = ACTION_READWRITE;
1251
      return fd;
1252
    }
1253
  if (errno != EACCES && errno != EROFS)
1254
     return fd;
1255
 
1256
  /* retry for read-only access */
1257
  rwflag = O_RDONLY;
1258
  fd = open (path, rwflag | crflag, mode);
1259
  if (fd >=0)
1260
    {
1261
      flags->action = ACTION_READ;
1262
      return fd;                /* success */
1263
    }
1264
 
1265
  if (errno != EACCES)
1266
    return fd;                  /* failure */
1267
 
1268
  /* retry for write-only access */
1269
  rwflag = O_WRONLY;
1270
  fd = open (path, rwflag | crflag, mode);
1271
  if (fd >=0)
1272
    {
1273
      flags->action = ACTION_WRITE;
1274
      return fd;                /* success */
1275
    }
1276
  return fd;                    /* failure */
1277
}
1278
 
1279
 
1280
/* open_external()-- Open an external file, unix specific version.
1281
 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1282
 * Returns NULL on operating system error. */
1283
 
1284
stream *
1285
open_external (st_parameter_open *opp, unit_flags *flags)
1286
{
1287
  int fd;
1288
 
1289
  if (flags->status == STATUS_SCRATCH)
1290
    {
1291
      fd = tempfile (opp);
1292
      if (flags->action == ACTION_UNSPECIFIED)
1293
        flags->action = ACTION_READWRITE;
1294
 
1295
#if HAVE_UNLINK_OPEN_FILE
1296
      /* We can unlink scratch files now and it will go away when closed. */
1297
      if (fd >= 0)
1298
        unlink (opp->file);
1299
#endif
1300
    }
1301
  else
1302
    {
1303
      /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1304
       * if it succeeds */
1305
      fd = regular_file (opp, flags);
1306
    }
1307
 
1308
  if (fd < 0)
1309
    return NULL;
1310
  fd = fix_fd (fd);
1311
 
1312
  return fd_to_stream (fd);
1313
}
1314
 
1315
 
1316
/* input_stream()-- Return a stream pointer to the default input stream.
1317
 * Called on initialization. */
1318
 
1319
stream *
1320
input_stream (void)
1321
{
1322
  return fd_to_stream (STDIN_FILENO);
1323
}
1324
 
1325
 
1326
/* output_stream()-- Return a stream pointer to the default output stream.
1327
 * Called on initialization. */
1328
 
1329
stream *
1330
output_stream (void)
1331
{
1332
  stream * s;
1333
 
1334
#if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1335
  setmode (STDOUT_FILENO, O_BINARY);
1336
#endif
1337
 
1338
  s = fd_to_stream (STDOUT_FILENO);
1339
  return s;
1340
}
1341
 
1342
 
1343
/* error_stream()-- Return a stream pointer to the default error stream.
1344
 * Called on initialization. */
1345
 
1346
stream *
1347
error_stream (void)
1348
{
1349
  stream * s;
1350
 
1351
#if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1352
  setmode (STDERR_FILENO, O_BINARY);
1353
#endif
1354
 
1355
  s = fd_to_stream (STDERR_FILENO);
1356
  return s;
1357
}
1358
 
1359
 
1360
/* compare_file_filename()-- Given an open stream and a fortran string
1361
 * that is a filename, figure out if the file is the same as the
1362
 * filename. */
1363
 
1364
int
1365
compare_file_filename (gfc_unit *u, const char *name, int len)
1366
{
1367
  char path[min(PATH_MAX, len + 1)];
1368
  struct stat st;
1369
#ifdef HAVE_WORKING_STAT
1370
  unix_stream *s;
1371
#else
1372
# ifdef __MINGW32__
1373
  uint64_t id1, id2;
1374
# endif
1375
#endif
1376
 
1377
  if (unpack_filename (path, name, len))
1378
    return 0;                    /* Can't be the same */
1379
 
1380
  /* If the filename doesn't exist, then there is no match with the
1381
   * existing file. */
1382
 
1383
  if (stat (path, &st) < 0)
1384
    return 0;
1385
 
1386
#ifdef HAVE_WORKING_STAT
1387
  s = (unix_stream *) (u->s);
1388
  return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1389
#else
1390
 
1391
# ifdef __MINGW32__
1392
  /* We try to match files by a unique ID.  On some filesystems (network
1393
     fs and FAT), we can't generate this unique ID, and will simply compare
1394
     filenames.  */
1395
  id1 = id_from_path (path);
1396
  id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1397
  if (id1 || id2)
1398
    return (id1 == id2);
1399
# endif
1400
 
1401
  if (len != u->file_len)
1402
    return 0;
1403
  return (memcmp(path, u->file, len) == 0);
1404
#endif
1405
}
1406
 
1407
 
1408
#ifdef HAVE_WORKING_STAT
1409
# define FIND_FILE0_DECL struct stat *st
1410
# define FIND_FILE0_ARGS st
1411
#else
1412
# define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1413
# define FIND_FILE0_ARGS id, file, file_len
1414
#endif
1415
 
1416
/* find_file0()-- Recursive work function for find_file() */
1417
 
1418
static gfc_unit *
1419
find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1420
{
1421
  gfc_unit *v;
1422
#if defined(__MINGW32__) && !HAVE_WORKING_STAT
1423
  uint64_t id1;
1424
#endif
1425
 
1426
  if (u == NULL)
1427
    return NULL;
1428
 
1429
#ifdef HAVE_WORKING_STAT
1430
  if (u->s != NULL)
1431
    {
1432
      unix_stream *s = (unix_stream *) (u->s);
1433
      if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1434
        return u;
1435
    }
1436
#else
1437
# ifdef __MINGW32__ 
1438
  if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1439
    {
1440
      if (id == id1)
1441
        return u;
1442
    }
1443
  else
1444
# endif
1445
    if (compare_string (u->file_len, u->file, file_len, file) == 0)
1446
      return u;
1447
#endif
1448
 
1449
  v = find_file0 (u->left, FIND_FILE0_ARGS);
1450
  if (v != NULL)
1451
    return v;
1452
 
1453
  v = find_file0 (u->right, FIND_FILE0_ARGS);
1454
  if (v != NULL)
1455
    return v;
1456
 
1457
  return NULL;
1458
}
1459
 
1460
 
1461
/* find_file()-- Take the current filename and see if there is a unit
1462
 * that has the file already open.  Returns a pointer to the unit if so. */
1463
 
1464
gfc_unit *
1465
find_file (const char *file, gfc_charlen_type file_len)
1466
{
1467
  char path[min(PATH_MAX, file_len + 1)];
1468
  struct stat st[1];
1469
  gfc_unit *u;
1470
#if defined(__MINGW32__) && !HAVE_WORKING_STAT
1471
  uint64_t id = 0ULL;
1472
#endif
1473
 
1474
  if (unpack_filename (path, file, file_len))
1475
    return NULL;
1476
 
1477
  if (stat (path, &st[0]) < 0)
1478
    return NULL;
1479
 
1480
#if defined(__MINGW32__) && !HAVE_WORKING_STAT
1481
  id = id_from_path (path);
1482
#endif
1483
 
1484
  __gthread_mutex_lock (&unit_lock);
1485
retry:
1486
  u = find_file0 (unit_root, FIND_FILE0_ARGS);
1487
  if (u != NULL)
1488
    {
1489
      /* Fast path.  */
1490
      if (! __gthread_mutex_trylock (&u->lock))
1491
        {
1492
          /* assert (u->closed == 0); */
1493
          __gthread_mutex_unlock (&unit_lock);
1494
          return u;
1495
        }
1496
 
1497
      inc_waiting_locked (u);
1498
    }
1499
  __gthread_mutex_unlock (&unit_lock);
1500
  if (u != NULL)
1501
    {
1502
      __gthread_mutex_lock (&u->lock);
1503
      if (u->closed)
1504
        {
1505
          __gthread_mutex_lock (&unit_lock);
1506
          __gthread_mutex_unlock (&u->lock);
1507
          if (predec_waiting_locked (u) == 0)
1508
            free (u);
1509
          goto retry;
1510
        }
1511
 
1512
      dec_waiting_unlocked (u);
1513
    }
1514
  return u;
1515
}
1516
 
1517
static gfc_unit *
1518
flush_all_units_1 (gfc_unit *u, int min_unit)
1519
{
1520
  while (u != NULL)
1521
    {
1522
      if (u->unit_number > min_unit)
1523
        {
1524
          gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1525
          if (r != NULL)
1526
            return r;
1527
        }
1528
      if (u->unit_number >= min_unit)
1529
        {
1530
          if (__gthread_mutex_trylock (&u->lock))
1531
            return u;
1532
          if (u->s)
1533
            sflush (u->s);
1534
          __gthread_mutex_unlock (&u->lock);
1535
        }
1536
      u = u->right;
1537
    }
1538
  return NULL;
1539
}
1540
 
1541
void
1542
flush_all_units (void)
1543
{
1544
  gfc_unit *u;
1545
  int min_unit = 0;
1546
 
1547
  __gthread_mutex_lock (&unit_lock);
1548
  do
1549
    {
1550
      u = flush_all_units_1 (unit_root, min_unit);
1551
      if (u != NULL)
1552
        inc_waiting_locked (u);
1553
      __gthread_mutex_unlock (&unit_lock);
1554
      if (u == NULL)
1555
        return;
1556
 
1557
      __gthread_mutex_lock (&u->lock);
1558
 
1559
      min_unit = u->unit_number + 1;
1560
 
1561
      if (u->closed == 0)
1562
        {
1563
          sflush (u->s);
1564
          __gthread_mutex_lock (&unit_lock);
1565
          __gthread_mutex_unlock (&u->lock);
1566
          (void) predec_waiting_locked (u);
1567
        }
1568
      else
1569
        {
1570
          __gthread_mutex_lock (&unit_lock);
1571
          __gthread_mutex_unlock (&u->lock);
1572
          if (predec_waiting_locked (u) == 0)
1573
            free (u);
1574
        }
1575
    }
1576
  while (1);
1577
}
1578
 
1579
 
1580
/* delete_file()-- Given a unit structure, delete the file associated
1581
 * with the unit.  Returns nonzero if something went wrong. */
1582
 
1583
int
1584
delete_file (gfc_unit * u)
1585
{
1586
  char path[min(PATH_MAX, u->file_len + 1)];
1587
  int err = unpack_filename (path, u->file, u->file_len);
1588
 
1589
  if (err)
1590
    {                           /* Shouldn't be possible */
1591
      errno = err;
1592
      return 1;
1593
    }
1594
 
1595
  return unlink (path);
1596
}
1597
 
1598
 
1599
/* file_exists()-- Returns nonzero if the current filename exists on
1600
 * the system */
1601
 
1602
int
1603
file_exists (const char *file, gfc_charlen_type file_len)
1604
{
1605
  char path[min(PATH_MAX, file_len + 1)];
1606
 
1607
  if (unpack_filename (path, file, file_len))
1608
    return 0;
1609
 
1610
  return !(access (path, F_OK));
1611
}
1612
 
1613
 
1614
/* file_size()-- Returns the size of the file.  */
1615
 
1616
GFC_IO_INT
1617
file_size (const char *file, gfc_charlen_type file_len)
1618
{
1619
  char path[min(PATH_MAX, file_len + 1)];
1620
  struct stat statbuf;
1621
 
1622
  if (unpack_filename (path, file, file_len))
1623
    return -1;
1624
 
1625
  if (stat (path, &statbuf) < 0)
1626
    return -1;
1627
 
1628
  return (GFC_IO_INT) statbuf.st_size;
1629
}
1630
 
1631
static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1632
 
1633
/* inquire_sequential()-- Given a fortran string, determine if the
1634
 * file is suitable for sequential access.  Returns a C-style
1635
 * string. */
1636
 
1637
const char *
1638
inquire_sequential (const char *string, int len)
1639
{
1640
  char path[min(PATH_MAX, len + 1)];
1641
  struct stat statbuf;
1642
 
1643
  if (string == NULL ||
1644
      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1645
    return unknown;
1646
 
1647
  if (S_ISREG (statbuf.st_mode) ||
1648
      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1649
    return unknown;
1650
 
1651
  if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1652
    return no;
1653
 
1654
  return unknown;
1655
}
1656
 
1657
 
1658
/* inquire_direct()-- Given a fortran string, determine if the file is
1659
 * suitable for direct access.  Returns a C-style string. */
1660
 
1661
const char *
1662
inquire_direct (const char *string, int len)
1663
{
1664
  char path[min(PATH_MAX, len + 1)];
1665
  struct stat statbuf;
1666
 
1667
  if (string == NULL ||
1668
      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1669
    return unknown;
1670
 
1671
  if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1672
    return unknown;
1673
 
1674
  if (S_ISDIR (statbuf.st_mode) ||
1675
      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1676
    return no;
1677
 
1678
  return unknown;
1679
}
1680
 
1681
 
1682
/* inquire_formatted()-- Given a fortran string, determine if the file
1683
 * is suitable for formatted form.  Returns a C-style string. */
1684
 
1685
const char *
1686
inquire_formatted (const char *string, int len)
1687
{
1688
  char path[min(PATH_MAX, len + 1)];
1689
  struct stat statbuf;
1690
 
1691
  if (string == NULL ||
1692
      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1693
    return unknown;
1694
 
1695
  if (S_ISREG (statbuf.st_mode) ||
1696
      S_ISBLK (statbuf.st_mode) ||
1697
      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1698
    return unknown;
1699
 
1700
  if (S_ISDIR (statbuf.st_mode))
1701
    return no;
1702
 
1703
  return unknown;
1704
}
1705
 
1706
 
1707
/* inquire_unformatted()-- Given a fortran string, determine if the file
1708
 * is suitable for unformatted form.  Returns a C-style string. */
1709
 
1710
const char *
1711
inquire_unformatted (const char *string, int len)
1712
{
1713
  return inquire_formatted (string, len);
1714
}
1715
 
1716
 
1717
/* inquire_access()-- Given a fortran string, determine if the file is
1718
 * suitable for access. */
1719
 
1720
static const char *
1721
inquire_access (const char *string, int len, int mode)
1722
{
1723
  char path[min(PATH_MAX, len + 1)];
1724
 
1725
  if (string == NULL || unpack_filename (path, string, len) ||
1726
      access (path, mode) < 0)
1727
    return no;
1728
 
1729
  return yes;
1730
}
1731
 
1732
 
1733
/* inquire_read()-- Given a fortran string, determine if the file is
1734
 * suitable for READ access. */
1735
 
1736
const char *
1737
inquire_read (const char *string, int len)
1738
{
1739
  return inquire_access (string, len, R_OK);
1740
}
1741
 
1742
 
1743
/* inquire_write()-- Given a fortran string, determine if the file is
1744
 * suitable for READ access. */
1745
 
1746
const char *
1747
inquire_write (const char *string, int len)
1748
{
1749
  return inquire_access (string, len, W_OK);
1750
}
1751
 
1752
 
1753
/* inquire_readwrite()-- Given a fortran string, determine if the file is
1754
 * suitable for read and write access. */
1755
 
1756
const char *
1757
inquire_readwrite (const char *string, int len)
1758
{
1759
  return inquire_access (string, len, R_OK | W_OK);
1760
}
1761
 
1762
 
1763
int
1764
stream_isatty (stream *s)
1765
{
1766
  return isatty (((unix_stream *) s)->fd);
1767
}
1768
 
1769
int
1770
stream_ttyname (stream *s  __attribute__ ((unused)),
1771
                char * buf  __attribute__ ((unused)),
1772
                size_t buflen  __attribute__ ((unused)))
1773
{
1774
#ifdef HAVE_TTYNAME_R
1775
  return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1776
#elif defined HAVE_TTYNAME
1777
  char *p;
1778
  size_t plen;
1779
  p = ttyname (((unix_stream *) s)->fd);
1780
  if (!p)
1781
    return errno;
1782
  plen = strlen (p);
1783
  if (buflen < plen)
1784
    plen = buflen;
1785
  memcpy (buf, p, plen);
1786
  return 0;
1787
#else
1788
  return ENOSYS;
1789
#endif
1790
}
1791
 
1792
 
1793
 
1794
 
1795
/* How files are stored:  This is an operating-system specific issue,
1796
   and therefore belongs here.  There are three cases to consider.
1797
 
1798
   Direct Access:
1799
      Records are written as block of bytes corresponding to the record
1800
      length of the file.  This goes for both formatted and unformatted
1801
      records.  Positioning is done explicitly for each data transfer,
1802
      so positioning is not much of an issue.
1803
 
1804
   Sequential Formatted:
1805
      Records are separated by newline characters.  The newline character
1806
      is prohibited from appearing in a string.  If it does, this will be
1807
      messed up on the next read.  End of file is also the end of a record.
1808
 
1809
   Sequential Unformatted:
1810
      In this case, we are merely copying bytes to and from main storage,
1811
      yet we need to keep track of varying record lengths.  We adopt
1812
      the solution used by f2c.  Each record contains a pair of length
1813
      markers:
1814
 
1815
        Length of record n in bytes
1816
        Data of record n
1817
        Length of record n in bytes
1818
 
1819
        Length of record n+1 in bytes
1820
        Data of record n+1
1821
        Length of record n+1 in bytes
1822
 
1823
     The length is stored at the end of a record to allow backspacing to the
1824
     previous record.  Between data transfer statements, the file pointer
1825
     is left pointing to the first length of the current record.
1826
 
1827
     ENDFILE records are never explicitly stored.
1828
 
1829
*/

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.