1 /* Copyright (C) 2002-2019 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 u2 = find_file (opp->file, opp->file_len);
520 if (u2 != NULL
521 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
522 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
523 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
524 {
525 unlock_unit (u2);
526 generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
527 goto cleanup;
528 }
529
530 if (u2 != NULL)
531 unlock_unit (u2);
532
533 /* If the unit specified is preconnected with a file specified to be open,
534 then clear the format buffer. */
535 if ((opp->common.unit == options.stdin_unit ||
536 opp->common.unit == options.stdout_unit ||
537 opp->common.unit == options.stderr_unit)
538 && (opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
539 fbuf_destroy (u);
540
541 /* Open file. */
542
543 s = open_external (opp, flags);
544 if (s == NULL)
545 {
546 char errbuf[256];
547 char *path = fc_strdup (opp->file, opp->file_len);
548 size_t msglen = opp->file_len + 22 + sizeof (errbuf);
549 char *msg = xmalloc (msglen);
550 snprintf (msg, msglen, "Cannot open file '%s': %s", path,
551 gf_strerror (errno, errbuf, sizeof (errbuf)));
552 generate_error (&opp->common, LIBERROR_OS, msg);
553 free (msg);
554 free (path);
555 goto cleanup;
556 }
557
558 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
559 flags->status = STATUS_OLD;
560
561 /* Create the unit structure. */
562
563 if (u->unit_number != opp->common.unit)
564 internal_error (&opp->common, "Unit number changed");
565 u->s = s;
566 u->flags = *flags;
567 u->read_bad = 0;
568 u->endfile = NO_ENDFILE;
569 u->last_record = 0;
570 u->current_record = 0;
571 u->mode = READING;
572 u->maxrec = 0;
573 u->bytes_left = 0;
574 u->saved_pos = 0;
575
576 if (flags->position == POSITION_APPEND)
577 {
578 if (sseek (u->s, 0, SEEK_END) < 0)
579 {
580 generate_error (&opp->common, LIBERROR_OS, NULL);
581 goto cleanup;
582 }
583 u->endfile = AT_ENDFILE;
584 }
585
586 /* Unspecified recl ends up with a processor dependent value. */
587
588 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
589 {
590 u->flags.has_recl = 1;
591 u->recl = opp->recl_in;
592 u->recl_subrecord = u->recl;
593 u->bytes_left = u->recl;
594 }
595 else
596 {
597 u->flags.has_recl = 0;
598 u->recl = default_recl;
599 if (compile_options.max_subrecord_length)
600 {
601 u->recl_subrecord = compile_options.max_subrecord_length;
602 }
603 else
604 {
605 switch (compile_options.record_marker)
606 {
607 case 0:
608 /* Fall through */
609 case sizeof (GFC_INTEGER_4):
610 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
611 break;
612
613 case sizeof (GFC_INTEGER_8):
614 u->recl_subrecord = max_offset - 16;
615 break;
616
617 default:
618 runtime_error ("Illegal value for record marker");
619 break;
620 }
621 }
622 }
623
624 /* If the file is direct access, calculate the maximum record number
625 via a division now instead of letting the multiplication overflow
626 later. */
627
628 if (flags->access == ACCESS_DIRECT)
629 u->maxrec = max_offset / u->recl;
630
631 if (flags->access == ACCESS_STREAM)
632 {
633 u->maxrec = max_offset;
634 /* F2018 (N2137) 12.10.2.26: If the connection is for stream
635 access recl is assigned the value -2. */
636 u->recl = -2;
637 u->bytes_left = 1;
638 u->strm_pos = stell (u->s) + 1;
639 }
640
641 u->filename = fc_strdup (opp->file, opp->file_len);
642
643 /* Curiously, the standard requires that the
644 position specifier be ignored for new files so a newly connected
645 file starts out at the initial point. We still need to figure
646 out if the file is at the end or not. */
647
648 test_endfile (u);
649
650 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
651 free (opp->file);
652
653 if (flags->form == FORM_FORMATTED)
654 {
655 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
656 fbuf_init (u, u->recl);
657 else
658 fbuf_init (u, 0);
659 }
660 else
661 u->fbuf = NULL;
662
663 /* Check if asynchrounous. */
664 if (flags->async == ASYNC_YES)
665 init_async_unit (u);
666 else
667 u->au = NULL;
668
669 return u;
670
671 cleanup:
672
673 /* Free memory associated with a temporary filename. */
674
675 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
676 free (opp->file);
677
678 fail:
679
680 close_unit (u);
681 return NULL;
682 }
683
684
685 /* Open a unit which is already open. This involves changing the
686 modes or closing what is there now and opening the new file. */
687
688 static void
already_open(st_parameter_open * opp,gfc_unit * u,unit_flags * flags)689 already_open (st_parameter_open *opp, gfc_unit *u, unit_flags *flags)
690 {
691 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
692 {
693 edit_modes (opp, u, flags);
694 return;
695 }
696
697 /* If the file is connected to something else, close it and open a
698 new unit. */
699
700 if (!compare_file_filename (u, opp->file, opp->file_len))
701 {
702 if (sclose (u->s) == -1)
703 {
704 unlock_unit (u);
705 generate_error (&opp->common, LIBERROR_OS,
706 "Error closing file in OPEN statement");
707 return;
708 }
709
710 u->s = NULL;
711
712 #if !HAVE_UNLINK_OPEN_FILE
713 if (u->filename && u->flags.status == STATUS_SCRATCH)
714 remove (u->filename);
715 #endif
716 free (u->filename);
717 u->filename = NULL;
718
719 u = new_unit (opp, u, flags);
720 if (u != NULL)
721 unlock_unit (u);
722 return;
723 }
724
725 edit_modes (opp, u, flags);
726 }
727
728
729 /* Open file. */
730
731 extern void st_open (st_parameter_open *opp);
732 export_proto(st_open);
733
734 void
st_open(st_parameter_open * opp)735 st_open (st_parameter_open *opp)
736 {
737 unit_flags flags;
738 gfc_unit *u = NULL;
739 GFC_INTEGER_4 cf = opp->common.flags;
740 unit_convert conv;
741
742 library_start (&opp->common);
743
744 /* Decode options. */
745 flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly;
746
747 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
748 find_option (&opp->common, opp->access, opp->access_len,
749 access_opt, "Bad ACCESS parameter in OPEN statement");
750
751 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
752 find_option (&opp->common, opp->action, opp->action_len,
753 action_opt, "Bad ACTION parameter in OPEN statement");
754
755 flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED :
756 find_option (&opp->common, opp->cc, opp->cc_len,
757 cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement");
758
759 flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED :
760 find_option (&opp->common, opp->share, opp->share_len,
761 share_opt, "Bad SHARE parameter in OPEN statement");
762
763 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
764 find_option (&opp->common, opp->blank, opp->blank_len,
765 blank_opt, "Bad BLANK parameter in OPEN statement");
766
767 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
768 find_option (&opp->common, opp->delim, opp->delim_len,
769 delim_opt, "Bad DELIM parameter in OPEN statement");
770
771 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
772 find_option (&opp->common, opp->pad, opp->pad_len,
773 pad_opt, "Bad PAD parameter in OPEN statement");
774
775 flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
776 find_option (&opp->common, opp->decimal, opp->decimal_len,
777 decimal_opt, "Bad DECIMAL parameter in OPEN statement");
778
779 flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
780 find_option (&opp->common, opp->encoding, opp->encoding_len,
781 encoding_opt, "Bad ENCODING parameter in OPEN statement");
782
783 flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
784 find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
785 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
786
787 flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
788 find_option (&opp->common, opp->round, opp->round_len,
789 round_opt, "Bad ROUND parameter in OPEN statement");
790
791 flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
792 find_option (&opp->common, opp->sign, opp->sign_len,
793 sign_opt, "Bad SIGN parameter in OPEN statement");
794
795 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
796 find_option (&opp->common, opp->form, opp->form_len,
797 form_opt, "Bad FORM parameter in OPEN statement");
798
799 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
800 find_option (&opp->common, opp->position, opp->position_len,
801 position_opt, "Bad POSITION parameter in OPEN statement");
802
803 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
804 find_option (&opp->common, opp->status, opp->status_len,
805 status_opt, "Bad STATUS parameter in OPEN statement");
806
807 /* First, we check wether the convert flag has been set via environment
808 variable. This overrides the convert tag in the open statement. */
809
810 conv = get_unformatted_convert (opp->common.unit);
811
812 if (conv == GFC_CONVERT_NONE)
813 {
814 /* Nothing has been set by environment variable, check the convert tag. */
815 if (cf & IOPARM_OPEN_HAS_CONVERT)
816 conv = find_option (&opp->common, opp->convert, opp->convert_len,
817 convert_opt,
818 "Bad CONVERT parameter in OPEN statement");
819 else
820 conv = compile_options.convert;
821 }
822
823 switch (conv)
824 {
825 case GFC_CONVERT_NATIVE:
826 case GFC_CONVERT_SWAP:
827 break;
828
829 case GFC_CONVERT_BIG:
830 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
831 break;
832
833 case GFC_CONVERT_LITTLE:
834 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
835 break;
836
837 default:
838 internal_error (&opp->common, "Illegal value for CONVERT");
839 break;
840 }
841
842 flags.convert = conv;
843
844 if (flags.position != POSITION_UNSPECIFIED
845 && flags.access == ACCESS_DIRECT)
846 generate_error (&opp->common, LIBERROR_BAD_OPTION,
847 "Cannot use POSITION with direct access files");
848
849 if (flags.readonly
850 && flags.action != ACTION_UNSPECIFIED && flags.action != ACTION_READ)
851 generate_error (&opp->common, LIBERROR_BAD_OPTION,
852 "ACTION conflicts with READONLY in OPEN statement");
853
854 if (flags.access == ACCESS_APPEND)
855 {
856 if (flags.position != POSITION_UNSPECIFIED
857 && flags.position != POSITION_APPEND)
858 generate_error (&opp->common, LIBERROR_BAD_OPTION,
859 "Conflicting ACCESS and POSITION flags in"
860 " OPEN statement");
861
862 notify_std (&opp->common, GFC_STD_GNU,
863 "Extension: APPEND as a value for ACCESS in OPEN statement");
864 flags.access = ACCESS_SEQUENTIAL;
865 flags.position = POSITION_APPEND;
866 }
867
868 if (flags.position == POSITION_UNSPECIFIED)
869 flags.position = POSITION_ASIS;
870
871 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
872 {
873 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
874 opp->common.unit = newunit_alloc ();
875 else if (opp->common.unit < 0)
876 {
877 u = find_unit (opp->common.unit);
878 if (u == NULL) /* Negative unit and no NEWUNIT-created unit found. */
879 {
880 generate_error (&opp->common, LIBERROR_BAD_OPTION,
881 "Bad unit number in OPEN statement");
882 library_end ();
883 return;
884 }
885 }
886
887 if (u == NULL)
888 u = find_or_create_unit (opp->common.unit);
889 if (u->s == NULL)
890 {
891 u = new_unit (opp, u, &flags);
892 if (u != NULL)
893 unlock_unit (u);
894 }
895 else
896 already_open (opp, u, &flags);
897 }
898
899 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
900 && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
901 *opp->newunit = opp->common.unit;
902
903 library_end ();
904 }
905