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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [io/] [open.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, 2007, 2008, 2009, 2010, 2011
2
   Free Software Foundation, Inc.
3
   Contributed by Andy Vaught
4
   F2003 I/O support contributed by Jerry DeLisle
5
 
6
This file is part of the GNU Fortran runtime library (libgfortran).
7
 
8
Libgfortran is free software; you can redistribute it and/or modify
9
it under the terms of the GNU General Public License as published by
10
the Free Software Foundation; either version 3, or (at your option)
11
any later version.
12
 
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
 
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
 
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
 
27
#include "io.h"
28
#include "fbuf.h"
29
#include "unix.h"
30
#include <unistd.h>
31
#include <string.h>
32
#include <errno.h>
33
#include <stdlib.h>
34
 
35
 
36
static const st_option access_opt[] = {
37
  {"sequential", ACCESS_SEQUENTIAL},
38
  {"direct", ACCESS_DIRECT},
39
  {"append", ACCESS_APPEND},
40
  {"stream", ACCESS_STREAM},
41
  {NULL, 0}
42
};
43
 
44
static const st_option action_opt[] =
45
{
46
  { "read", ACTION_READ},
47
  { "write", ACTION_WRITE},
48
  { "readwrite", ACTION_READWRITE},
49
  { NULL, 0}
50
};
51
 
52
static const st_option blank_opt[] =
53
{
54
  { "null", BLANK_NULL},
55
  { "zero", BLANK_ZERO},
56
  { NULL, 0}
57
};
58
 
59
static const st_option delim_opt[] =
60
{
61
  { "none", DELIM_NONE},
62
  { "apostrophe", DELIM_APOSTROPHE},
63
  { "quote", DELIM_QUOTE},
64
  { NULL, 0}
65
};
66
 
67
static const st_option form_opt[] =
68
{
69
  { "formatted", FORM_FORMATTED},
70
  { "unformatted", FORM_UNFORMATTED},
71
  { NULL, 0}
72
};
73
 
74
static const st_option position_opt[] =
75
{
76
  { "asis", POSITION_ASIS},
77
  { "rewind", POSITION_REWIND},
78
  { "append", POSITION_APPEND},
79
  { NULL, 0}
80
};
81
 
82
static const st_option status_opt[] =
83
{
84
  { "unknown", STATUS_UNKNOWN},
85
  { "old", STATUS_OLD},
86
  { "new", STATUS_NEW},
87
  { "replace", STATUS_REPLACE},
88
  { "scratch", STATUS_SCRATCH},
89
  { NULL, 0}
90
};
91
 
92
static const st_option pad_opt[] =
93
{
94
  { "yes", PAD_YES},
95
  { "no", PAD_NO},
96
  { NULL, 0}
97
};
98
 
99
static const st_option decimal_opt[] =
100
{
101
  { "point", DECIMAL_POINT},
102
  { "comma", DECIMAL_COMMA},
103
  { NULL, 0}
104
};
105
 
106
static const st_option encoding_opt[] =
107
{
108
  { "utf-8", ENCODING_UTF8},
109
  { "default", ENCODING_DEFAULT},
110
  { NULL, 0}
111
};
112
 
113
static const st_option round_opt[] =
114
{
115
  { "up", ROUND_UP},
116
  { "down", ROUND_DOWN},
117
  { "zero", ROUND_ZERO},
118
  { "nearest", ROUND_NEAREST},
119
  { "compatible", ROUND_COMPATIBLE},
120
  { "processor_defined", ROUND_PROCDEFINED},
121
  { NULL, 0}
122
};
123
 
124
static const st_option sign_opt[] =
125
{
126
  { "plus", SIGN_PLUS},
127
  { "suppress", SIGN_SUPPRESS},
128
  { "processor_defined", SIGN_PROCDEFINED},
129
  { NULL, 0}
130
};
131
 
132
static const st_option convert_opt[] =
133
{
134
  { "native", GFC_CONVERT_NATIVE},
135
  { "swap", GFC_CONVERT_SWAP},
136
  { "big_endian", GFC_CONVERT_BIG},
137
  { "little_endian", GFC_CONVERT_LITTLE},
138
  { NULL, 0}
139
};
140
 
141
static const st_option async_opt[] =
142
{
143
  { "yes", ASYNC_YES},
144
  { "no", ASYNC_NO},
145
  { NULL, 0}
146
};
147
 
148
/* Given a unit, test to see if the file is positioned at the terminal
149
   point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
150
   This prevents us from changing the state from AFTER_ENDFILE to
151
   AT_ENDFILE.  */
152
 
153
static void
154
test_endfile (gfc_unit * u)
155
{
156
  if (u->endfile == NO_ENDFILE && ssize (u->s) == stell (u->s))
157
    u->endfile = AT_ENDFILE;
158
}
159
 
160
 
161
/* Change the modes of a file, those that are allowed * to be
162
   changed.  */
163
 
164
static void
165
edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
166
{
167
  /* Complain about attempts to change the unchangeable.  */
168
 
169
  if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
170
      u->flags.status != flags->status)
171
    generate_error (&opp->common, LIBERROR_BAD_OPTION,
172
                    "Cannot change STATUS parameter in OPEN statement");
173
 
174
  if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
175
    generate_error (&opp->common, LIBERROR_BAD_OPTION,
176
                    "Cannot change ACCESS parameter in OPEN statement");
177
 
178
  if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
179
    generate_error (&opp->common, LIBERROR_BAD_OPTION,
180
                    "Cannot change FORM parameter in OPEN statement");
181
 
182
  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
183
      && opp->recl_in != u->recl)
184
    generate_error (&opp->common, LIBERROR_BAD_OPTION,
185
                    "Cannot change RECL parameter in OPEN statement");
186
 
187
  if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
188
    generate_error (&opp->common, LIBERROR_BAD_OPTION,
189
                    "Cannot change ACTION parameter in OPEN statement");
190
 
191
  /* Status must be OLD if present.  */
192
 
193
  if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
194
      flags->status != STATUS_UNKNOWN)
195
    {
196
      if (flags->status == STATUS_SCRATCH)
197
        notify_std (&opp->common, GFC_STD_GNU,
198
                    "OPEN statement must have a STATUS of OLD or UNKNOWN");
199
      else
200
        generate_error (&opp->common, LIBERROR_BAD_OPTION,
201
                    "OPEN statement must have a STATUS of OLD or UNKNOWN");
202
    }
203
 
204
  if (u->flags.form == FORM_UNFORMATTED)
205
    {
206
      if (flags->delim != DELIM_UNSPECIFIED)
207
        generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
208
                        "DELIM parameter conflicts with UNFORMATTED form in "
209
                        "OPEN statement");
210
 
211
      if (flags->blank != BLANK_UNSPECIFIED)
212
        generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
213
                        "BLANK parameter conflicts with UNFORMATTED form in "
214
                        "OPEN statement");
215
 
216
      if (flags->pad != PAD_UNSPECIFIED)
217
        generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
218
                        "PAD parameter conflicts with UNFORMATTED form in "
219
                        "OPEN statement");
220
 
221
      if (flags->decimal != DECIMAL_UNSPECIFIED)
222
        generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
223
                        "DECIMAL parameter conflicts with UNFORMATTED form in "
224
                        "OPEN statement");
225
 
226
      if (flags->encoding != ENCODING_UNSPECIFIED)
227
        generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
228
                        "ENCODING parameter conflicts with UNFORMATTED form in "
229
                        "OPEN statement");
230
 
231
      if (flags->round != ROUND_UNSPECIFIED)
232
        generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
233
                        "ROUND parameter conflicts with UNFORMATTED form in "
234
                        "OPEN statement");
235
 
236
      if (flags->sign != SIGN_UNSPECIFIED)
237
        generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
238
                        "SIGN parameter conflicts with UNFORMATTED form in "
239
                        "OPEN statement");
240
    }
241
 
242
  if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
243
    {
244
      /* Change the changeable:  */
245
      if (flags->blank != BLANK_UNSPECIFIED)
246
        u->flags.blank = flags->blank;
247
      if (flags->delim != DELIM_UNSPECIFIED)
248
        u->flags.delim = flags->delim;
249
      if (flags->pad != PAD_UNSPECIFIED)
250
        u->flags.pad = flags->pad;
251
      if (flags->decimal != DECIMAL_UNSPECIFIED)
252
        u->flags.decimal = flags->decimal;
253
      if (flags->encoding != ENCODING_UNSPECIFIED)
254
        u->flags.encoding = flags->encoding;
255
      if (flags->async != ASYNC_UNSPECIFIED)
256
        u->flags.async = flags->async;
257
      if (flags->round != ROUND_UNSPECIFIED)
258
        u->flags.round = flags->round;
259
      if (flags->sign != SIGN_UNSPECIFIED)
260
        u->flags.sign = flags->sign;
261
    }
262
 
263
  /* Reposition the file if necessary.  */
264
 
265
  switch (flags->position)
266
    {
267
    case POSITION_UNSPECIFIED:
268
    case POSITION_ASIS:
269
      break;
270
 
271
    case POSITION_REWIND:
272
      if (sseek (u->s, 0, SEEK_SET) != 0)
273
        goto seek_error;
274
 
275
      u->current_record = 0;
276
      u->last_record = 0;
277
 
278
      test_endfile (u);
279
      break;
280
 
281
    case POSITION_APPEND:
282
      if (sseek (u->s, 0, SEEK_END) < 0)
283
        goto seek_error;
284
 
285
      if (flags->access != ACCESS_STREAM)
286
        u->current_record = 0;
287
 
288
      u->endfile = AT_ENDFILE;  /* We are at the end.  */
289
      break;
290
 
291
    seek_error:
292
      generate_error (&opp->common, LIBERROR_OS, NULL);
293
      break;
294
    }
295
 
296
  unlock_unit (u);
297
}
298
 
299
 
300
/* Open an unused unit.  */
301
 
302
gfc_unit *
303
new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
304
{
305
  gfc_unit *u2;
306
  stream *s;
307
  char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
308
 
309
  /* Change unspecifieds to defaults.  Leave (flags->action ==
310
     ACTION_UNSPECIFIED) alone so open_external() can set it based on
311
     what type of open actually works.  */
312
 
313
  if (flags->access == ACCESS_UNSPECIFIED)
314
    flags->access = ACCESS_SEQUENTIAL;
315
 
316
  if (flags->form == FORM_UNSPECIFIED)
317
    flags->form = (flags->access == ACCESS_SEQUENTIAL)
318
      ? FORM_FORMATTED : FORM_UNFORMATTED;
319
 
320
  if (flags->async == ASYNC_UNSPECIFIED)
321
    flags->async = ASYNC_NO;
322
 
323
  if (flags->status == STATUS_UNSPECIFIED)
324
    flags->status = STATUS_UNKNOWN;
325
 
326
  /* Checks.  */
327
 
328
  if (flags->delim == DELIM_UNSPECIFIED)
329
    flags->delim = DELIM_NONE;
330
  else
331
    {
332
      if (flags->form == FORM_UNFORMATTED)
333
        {
334
          generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
335
                          "DELIM parameter conflicts with UNFORMATTED form in "
336
                          "OPEN statement");
337
          goto fail;
338
        }
339
    }
340
 
341
  if (flags->blank == BLANK_UNSPECIFIED)
342
    flags->blank = BLANK_NULL;
343
  else
344
    {
345
      if (flags->form == FORM_UNFORMATTED)
346
        {
347
          generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
348
                          "BLANK parameter conflicts with UNFORMATTED form in "
349
                          "OPEN statement");
350
          goto fail;
351
        }
352
    }
353
 
354
  if (flags->pad == PAD_UNSPECIFIED)
355
    flags->pad = PAD_YES;
356
  else
357
    {
358
      if (flags->form == FORM_UNFORMATTED)
359
        {
360
          generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
361
                          "PAD parameter conflicts with UNFORMATTED form in "
362
                          "OPEN statement");
363
          goto fail;
364
        }
365
    }
366
 
367
  if (flags->decimal == DECIMAL_UNSPECIFIED)
368
    flags->decimal = DECIMAL_POINT;
369
  else
370
    {
371
      if (flags->form == FORM_UNFORMATTED)
372
        {
373
          generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
374
                          "DECIMAL parameter conflicts with UNFORMATTED form "
375
                          "in OPEN statement");
376
          goto fail;
377
        }
378
    }
379
 
380
  if (flags->encoding == ENCODING_UNSPECIFIED)
381
    flags->encoding = ENCODING_DEFAULT;
382
  else
383
    {
384
      if (flags->form == FORM_UNFORMATTED)
385
        {
386
          generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
387
                          "ENCODING parameter conflicts with UNFORMATTED form in "
388
                          "OPEN statement");
389
          goto fail;
390
        }
391
    }
392
 
393
  /* NB: the value for ROUND when it's not specified by the user does not
394
         have to be PROCESSOR_DEFINED; the standard says that it is
395
         processor dependent, and requires that it is one of the
396
         possible value (see F2003, 9.4.5.13).  */
397
  if (flags->round == ROUND_UNSPECIFIED)
398
    flags->round = ROUND_PROCDEFINED;
399
  else
400
    {
401
      if (flags->form == FORM_UNFORMATTED)
402
        {
403
          generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
404
                          "ROUND parameter conflicts with UNFORMATTED form in "
405
                          "OPEN statement");
406
          goto fail;
407
        }
408
    }
409
 
410
  if (flags->sign == SIGN_UNSPECIFIED)
411
    flags->sign = SIGN_PROCDEFINED;
412
  else
413
    {
414
      if (flags->form == FORM_UNFORMATTED)
415
        {
416
          generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
417
                          "SIGN parameter conflicts with UNFORMATTED form in "
418
                          "OPEN statement");
419
          goto fail;
420
        }
421
    }
422
 
423
  if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
424
   {
425
     generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
426
                     "ACCESS parameter conflicts with SEQUENTIAL access in "
427
                     "OPEN statement");
428
     goto fail;
429
   }
430
  else
431
   if (flags->position == POSITION_UNSPECIFIED)
432
     flags->position = POSITION_ASIS;
433
 
434
  if (flags->access == ACCESS_DIRECT
435
      && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
436
    {
437
      generate_error (&opp->common, LIBERROR_MISSING_OPTION,
438
                      "Missing RECL parameter in OPEN statement");
439
      goto fail;
440
    }
441
 
442
  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
443
    {
444
      generate_error (&opp->common, LIBERROR_BAD_OPTION,
445
                      "RECL parameter is non-positive in OPEN statement");
446
      goto fail;
447
    }
448
 
449
  switch (flags->status)
450
    {
451
    case STATUS_SCRATCH:
452
      if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
453
        {
454
          opp->file = NULL;
455
          break;
456
        }
457
 
458
      generate_error (&opp->common, LIBERROR_BAD_OPTION,
459
                      "FILE parameter must not be present in OPEN statement");
460
      goto fail;
461
 
462
    case STATUS_OLD:
463
    case STATUS_NEW:
464
    case STATUS_REPLACE:
465
    case STATUS_UNKNOWN:
466
      if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
467
        break;
468
 
469
      opp->file = tmpname;
470
      opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
471
                               (int) opp->common.unit);
472
      break;
473
 
474
    default:
475
      internal_error (&opp->common, "new_unit(): Bad status");
476
    }
477
 
478
  /* Make sure the file isn't already open someplace else.
479
     Do not error if opening file preconnected to stdin, stdout, stderr.  */
480
 
481
  u2 = NULL;
482
  if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
483
    u2 = find_file (opp->file, opp->file_len);
484
  if (u2 != NULL
485
      && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
486
      && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
487
      && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
488
    {
489
      unlock_unit (u2);
490
      generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
491
      goto cleanup;
492
    }
493
 
494
  if (u2 != NULL)
495
    unlock_unit (u2);
496
 
497
  /* Open file.  */
498
 
499
  s = open_external (opp, flags);
500
  if (s == NULL)
501
    {
502
      char *path, *msg;
503
      size_t msglen;
504
      path = (char *) gfc_alloca (opp->file_len + 1);
505
      msglen = opp->file_len + 51;
506
      msg = (char *) gfc_alloca (msglen);
507
      unpack_filename (path, opp->file, opp->file_len);
508
 
509
      switch (errno)
510
        {
511
        case ENOENT:
512
          snprintf (msg, msglen, "File '%s' does not exist", path);
513
          break;
514
 
515
        case EEXIST:
516
          snprintf (msg, msglen, "File '%s' already exists", path);
517
          break;
518
 
519
        case EACCES:
520
          snprintf (msg, msglen,
521
                    "Permission denied trying to open file '%s'", path);
522
          break;
523
 
524
        case EISDIR:
525
          snprintf (msg, msglen, "'%s' is a directory", path);
526
          break;
527
 
528
        default:
529
          msg = NULL;
530
        }
531
 
532
      generate_error (&opp->common, LIBERROR_OS, msg);
533
      goto cleanup;
534
    }
535
 
536
  if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
537
    flags->status = STATUS_OLD;
538
 
539
  /* Create the unit structure.  */
540
 
541
  u->file = get_mem (opp->file_len);
542
  if (u->unit_number != opp->common.unit)
543
    internal_error (&opp->common, "Unit number changed");
544
  u->s = s;
545
  u->flags = *flags;
546
  u->read_bad = 0;
547
  u->endfile = NO_ENDFILE;
548
  u->last_record = 0;
549
  u->current_record = 0;
550
  u->mode = READING;
551
  u->maxrec = 0;
552
  u->bytes_left = 0;
553
  u->saved_pos = 0;
554
 
555
  if (flags->position == POSITION_APPEND)
556
    {
557
      if (sseek (u->s, 0, SEEK_END) < 0)
558
        generate_error (&opp->common, LIBERROR_OS, NULL);
559
      u->endfile = AT_ENDFILE;
560
    }
561
 
562
  /* Unspecified recl ends up with a processor dependent value.  */
563
 
564
  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
565
    {
566
      u->flags.has_recl = 1;
567
      u->recl = opp->recl_in;
568
      u->recl_subrecord = u->recl;
569
      u->bytes_left = u->recl;
570
    }
571
  else
572
    {
573
      u->flags.has_recl = 0;
574
      u->recl = max_offset;
575
      if (compile_options.max_subrecord_length)
576
        {
577
          u->recl_subrecord = compile_options.max_subrecord_length;
578
        }
579
      else
580
        {
581
          switch (compile_options.record_marker)
582
            {
583
            case 0:
584
              /* Fall through */
585
            case sizeof (GFC_INTEGER_4):
586
              u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
587
              break;
588
 
589
            case sizeof (GFC_INTEGER_8):
590
              u->recl_subrecord = max_offset - 16;
591
              break;
592
 
593
            default:
594
              runtime_error ("Illegal value for record marker");
595
              break;
596
            }
597
        }
598
    }
599
 
600
  /* If the file is direct access, calculate the maximum record number
601
     via a division now instead of letting the multiplication overflow
602
     later.  */
603
 
604
  if (flags->access == ACCESS_DIRECT)
605
    u->maxrec = max_offset / u->recl;
606
 
607
  if (flags->access == ACCESS_STREAM)
608
    {
609
      u->maxrec = max_offset;
610
      u->recl = 1;
611
      u->bytes_left = 1;
612
      u->strm_pos = stell (u->s) + 1;
613
    }
614
 
615
  memmove (u->file, opp->file, opp->file_len);
616
  u->file_len = opp->file_len;
617
 
618
  /* Curiously, the standard requires that the
619
     position specifier be ignored for new files so a newly connected
620
     file starts out at the initial point.  We still need to figure
621
     out if the file is at the end or not.  */
622
 
623
  test_endfile (u);
624
 
625
  if (flags->status == STATUS_SCRATCH && opp->file != NULL)
626
    free (opp->file);
627
 
628
  if (flags->form == FORM_FORMATTED)
629
    {
630
      if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
631
        fbuf_init (u, u->recl);
632
      else
633
        fbuf_init (u, 0);
634
    }
635
  else
636
    u->fbuf = NULL;
637
 
638
 
639
 
640
  return u;
641
 
642
 cleanup:
643
 
644
  /* Free memory associated with a temporary filename.  */
645
 
646
  if (flags->status == STATUS_SCRATCH && opp->file != NULL)
647
    free (opp->file);
648
 
649
 fail:
650
 
651
  close_unit (u);
652
  return NULL;
653
}
654
 
655
 
656
/* Open a unit which is already open.  This involves changing the
657
   modes or closing what is there now and opening the new file.  */
658
 
659
static void
660
already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
661
{
662
  if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
663
    {
664
      edit_modes (opp, u, flags);
665
      return;
666
    }
667
 
668
  /* If the file is connected to something else, close it and open a
669
     new unit.  */
670
 
671
  if (!compare_file_filename (u, opp->file, opp->file_len))
672
    {
673
#if !HAVE_UNLINK_OPEN_FILE
674
      char *path = NULL;
675
      if (u->file && u->flags.status == STATUS_SCRATCH)
676
        {
677
          path = (char *) gfc_alloca (u->file_len + 1);
678
          unpack_filename (path, u->file, u->file_len);
679
        }
680
#endif
681
 
682
      if (sclose (u->s) == -1)
683
        {
684
          unlock_unit (u);
685
          generate_error (&opp->common, LIBERROR_OS,
686
                          "Error closing file in OPEN statement");
687
          return;
688
        }
689
 
690
      u->s = NULL;
691
      free (u->file);
692
      u->file = NULL;
693
      u->file_len = 0;
694
 
695
#if !HAVE_UNLINK_OPEN_FILE
696
      if (path != NULL)
697
        unlink (path);
698
#endif
699
 
700
      u = new_unit (opp, u, flags);
701
      if (u != NULL)
702
        unlock_unit (u);
703
      return;
704
    }
705
 
706
  edit_modes (opp, u, flags);
707
}
708
 
709
 
710
/* Open file.  */
711
 
712
extern void st_open (st_parameter_open *opp);
713
export_proto(st_open);
714
 
715
void
716
st_open (st_parameter_open *opp)
717
{
718
  unit_flags flags;
719
  gfc_unit *u = NULL;
720
  GFC_INTEGER_4 cf = opp->common.flags;
721
  unit_convert conv;
722
 
723
  library_start (&opp->common);
724
 
725
  /* Decode options.  */
726
 
727
  flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
728
    find_option (&opp->common, opp->access, opp->access_len,
729
                 access_opt, "Bad ACCESS parameter in OPEN statement");
730
 
731
  flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
732
    find_option (&opp->common, opp->action, opp->action_len,
733
                 action_opt, "Bad ACTION parameter in OPEN statement");
734
 
735
  flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
736
    find_option (&opp->common, opp->blank, opp->blank_len,
737
                 blank_opt, "Bad BLANK parameter in OPEN statement");
738
 
739
  flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
740
    find_option (&opp->common, opp->delim, opp->delim_len,
741
                 delim_opt, "Bad DELIM parameter in OPEN statement");
742
 
743
  flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
744
    find_option (&opp->common, opp->pad, opp->pad_len,
745
                 pad_opt, "Bad PAD parameter in OPEN statement");
746
 
747
  flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
748
    find_option (&opp->common, opp->decimal, opp->decimal_len,
749
                 decimal_opt, "Bad DECIMAL parameter in OPEN statement");
750
 
751
  flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
752
    find_option (&opp->common, opp->encoding, opp->encoding_len,
753
                 encoding_opt, "Bad ENCODING parameter in OPEN statement");
754
 
755
  flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
756
    find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
757
                 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
758
 
759
  flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
760
    find_option (&opp->common, opp->round, opp->round_len,
761
                 round_opt, "Bad ROUND parameter in OPEN statement");
762
 
763
  flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
764
    find_option (&opp->common, opp->sign, opp->sign_len,
765
                 sign_opt, "Bad SIGN parameter in OPEN statement");
766
 
767
  flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
768
    find_option (&opp->common, opp->form, opp->form_len,
769
                 form_opt, "Bad FORM parameter in OPEN statement");
770
 
771
  flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
772
    find_option (&opp->common, opp->position, opp->position_len,
773
                 position_opt, "Bad POSITION parameter in OPEN statement");
774
 
775
  flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
776
    find_option (&opp->common, opp->status, opp->status_len,
777
                 status_opt, "Bad STATUS parameter in OPEN statement");
778
 
779
  /* First, we check wether the convert flag has been set via environment
780
     variable.  This overrides the convert tag in the open statement.  */
781
 
782
  conv = get_unformatted_convert (opp->common.unit);
783
 
784
  if (conv == GFC_CONVERT_NONE)
785
    {
786
      /* Nothing has been set by environment variable, check the convert tag.  */
787
      if (cf & IOPARM_OPEN_HAS_CONVERT)
788
        conv = find_option (&opp->common, opp->convert, opp->convert_len,
789
                            convert_opt,
790
                            "Bad CONVERT parameter in OPEN statement");
791
      else
792
        conv = compile_options.convert;
793
    }
794
 
795
  /* We use big_endian, which is 0 on little-endian machines
796
     and 1 on big-endian machines.  */
797
  switch (conv)
798
    {
799
    case GFC_CONVERT_NATIVE:
800
    case GFC_CONVERT_SWAP:
801
      break;
802
 
803
    case GFC_CONVERT_BIG:
804
      conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
805
      break;
806
 
807
    case GFC_CONVERT_LITTLE:
808
      conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
809
      break;
810
 
811
    default:
812
      internal_error (&opp->common, "Illegal value for CONVERT");
813
      break;
814
    }
815
 
816
  flags.convert = conv;
817
 
818
  if (!(opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) && opp->common.unit < 0)
819
    generate_error (&opp->common, LIBERROR_BAD_OPTION,
820
                    "Bad unit number in OPEN statement");
821
 
822
  if (flags.position != POSITION_UNSPECIFIED
823
      && flags.access == ACCESS_DIRECT)
824
    generate_error (&opp->common, LIBERROR_BAD_OPTION,
825
                    "Cannot use POSITION with direct access files");
826
 
827
  if (flags.access == ACCESS_APPEND)
828
    {
829
      if (flags.position != POSITION_UNSPECIFIED
830
          && flags.position != POSITION_APPEND)
831
        generate_error (&opp->common, LIBERROR_BAD_OPTION,
832
                        "Conflicting ACCESS and POSITION flags in"
833
                        " OPEN statement");
834
 
835
      notify_std (&opp->common, GFC_STD_GNU,
836
                  "Extension: APPEND as a value for ACCESS in OPEN statement");
837
      flags.access = ACCESS_SEQUENTIAL;
838
      flags.position = POSITION_APPEND;
839
    }
840
 
841
  if (flags.position == POSITION_UNSPECIFIED)
842
    flags.position = POSITION_ASIS;
843
 
844
  if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
845
    {
846
      if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
847
        {
848
          *opp->newunit = get_unique_unit_number(opp);
849
          opp->common.unit = *opp->newunit;
850
        }
851
 
852
      u = find_or_create_unit (opp->common.unit);
853
      if (u->s == NULL)
854
        {
855
          u = new_unit (opp, u, &flags);
856
          if (u != NULL)
857
            unlock_unit (u);
858
        }
859
      else
860
        already_open (opp, u, &flags);
861
    }
862
 
863
  library_end ();
864
}

powered by: WebSVN 2.1.0

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