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