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