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