1 /* Copyright (C) 2002-2013 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran runtime library (libgfortran).
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)
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.
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.
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/>. */
35 static const st_option access_opt[] = {
36 {"sequential", ACCESS_SEQUENTIAL},
37 {"direct", ACCESS_DIRECT},
38 {"append", ACCESS_APPEND},
39 {"stream", ACCESS_STREAM},
43 static const st_option action_opt[] =
45 { "read", ACTION_READ},
46 { "write", ACTION_WRITE},
47 { "readwrite", ACTION_READWRITE},
51 static const st_option blank_opt[] =
53 { "null", BLANK_NULL},
54 { "zero", BLANK_ZERO},
58 static const st_option delim_opt[] =
60 { "none", DELIM_NONE},
61 { "apostrophe", DELIM_APOSTROPHE},
62 { "quote", DELIM_QUOTE},
66 static const st_option form_opt[] =
68 { "formatted", FORM_FORMATTED},
69 { "unformatted", FORM_UNFORMATTED},
73 static const st_option position_opt[] =
75 { "asis", POSITION_ASIS},
76 { "rewind", POSITION_REWIND},
77 { "append", POSITION_APPEND},
81 static const st_option status_opt[] =
83 { "unknown", STATUS_UNKNOWN},
86 { "replace", STATUS_REPLACE},
87 { "scratch", STATUS_SCRATCH},
91 static const st_option pad_opt[] =
98 static const st_option decimal_opt[] =
100 { "point", DECIMAL_POINT},
101 { "comma", DECIMAL_COMMA},
105 static const st_option encoding_opt[] =
107 { "utf-8", ENCODING_UTF8},
108 { "default", ENCODING_DEFAULT},
112 static const st_option round_opt[] =
115 { "down", ROUND_DOWN},
116 { "zero", ROUND_ZERO},
117 { "nearest", ROUND_NEAREST},
118 { "compatible", ROUND_COMPATIBLE},
119 { "processor_defined", ROUND_PROCDEFINED},
123 static const st_option sign_opt[] =
125 { "plus", SIGN_PLUS},
126 { "suppress", SIGN_SUPPRESS},
127 { "processor_defined", SIGN_PROCDEFINED},
131 static const st_option convert_opt[] =
133 { "native", GFC_CONVERT_NATIVE},
134 { "swap", GFC_CONVERT_SWAP},
135 { "big_endian", GFC_CONVERT_BIG},
136 { "little_endian", GFC_CONVERT_LITTLE},
140 static const st_option async_opt[] =
147 /* Given a unit, test to see if the file is positioned at the terminal
148 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
149 This prevents us from changing the state from AFTER_ENDFILE to
153 test_endfile (gfc_unit * u)
155 if (u->endfile == NO_ENDFILE)
157 gfc_offset sz = ssize (u->s);
158 if (sz == 0 || sz == stell (u->s))
159 u->endfile = AT_ENDFILE;
164 /* Change the modes of a file, those that are allowed * to be
168 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
170 /* Complain about attempts to change the unchangeable. */
172 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
173 u->flags.status != flags->status)
174 generate_error (&opp->common, LIBERROR_BAD_OPTION,
175 "Cannot change STATUS parameter in OPEN statement");
177 if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
178 generate_error (&opp->common, LIBERROR_BAD_OPTION,
179 "Cannot change ACCESS parameter in OPEN statement");
181 if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
182 generate_error (&opp->common, LIBERROR_BAD_OPTION,
183 "Cannot change FORM parameter in OPEN statement");
185 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
186 && opp->recl_in != u->recl)
187 generate_error (&opp->common, LIBERROR_BAD_OPTION,
188 "Cannot change RECL parameter in OPEN statement");
190 if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
191 generate_error (&opp->common, LIBERROR_BAD_OPTION,
192 "Cannot change ACTION parameter in OPEN statement");
194 /* Status must be OLD if present. */
196 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
197 flags->status != STATUS_UNKNOWN)
199 if (flags->status == STATUS_SCRATCH)
200 notify_std (&opp->common, GFC_STD_GNU,
201 "OPEN statement must have a STATUS of OLD or UNKNOWN");
203 generate_error (&opp->common, LIBERROR_BAD_OPTION,
204 "OPEN statement must have a STATUS of OLD or UNKNOWN");
207 if (u->flags.form == FORM_UNFORMATTED)
209 if (flags->delim != DELIM_UNSPECIFIED)
210 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
211 "DELIM parameter conflicts with UNFORMATTED form in "
214 if (flags->blank != BLANK_UNSPECIFIED)
215 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
216 "BLANK parameter conflicts with UNFORMATTED form in "
219 if (flags->pad != PAD_UNSPECIFIED)
220 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
221 "PAD parameter conflicts with UNFORMATTED form in "
224 if (flags->decimal != DECIMAL_UNSPECIFIED)
225 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
226 "DECIMAL parameter conflicts with UNFORMATTED form in "
229 if (flags->encoding != ENCODING_UNSPECIFIED)
230 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
231 "ENCODING parameter conflicts with UNFORMATTED form in "
234 if (flags->round != ROUND_UNSPECIFIED)
235 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
236 "ROUND parameter conflicts with UNFORMATTED form in "
239 if (flags->sign != SIGN_UNSPECIFIED)
240 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
241 "SIGN parameter conflicts with UNFORMATTED form in "
245 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
247 /* Change the changeable: */
248 if (flags->blank != BLANK_UNSPECIFIED)
249 u->flags.blank = flags->blank;
250 if (flags->delim != DELIM_UNSPECIFIED)
251 u->flags.delim = flags->delim;
252 if (flags->pad != PAD_UNSPECIFIED)
253 u->flags.pad = flags->pad;
254 if (flags->decimal != DECIMAL_UNSPECIFIED)
255 u->flags.decimal = flags->decimal;
256 if (flags->encoding != ENCODING_UNSPECIFIED)
257 u->flags.encoding = flags->encoding;
258 if (flags->async != ASYNC_UNSPECIFIED)
259 u->flags.async = flags->async;
260 if (flags->round != ROUND_UNSPECIFIED)
261 u->flags.round = flags->round;
262 if (flags->sign != SIGN_UNSPECIFIED)
263 u->flags.sign = flags->sign;
266 /* Reposition the file if necessary. */
268 switch (flags->position)
270 case POSITION_UNSPECIFIED:
274 case POSITION_REWIND:
275 if (sseek (u->s, 0, SEEK_SET) != 0)
278 u->current_record = 0;
284 case POSITION_APPEND:
285 if (sseek (u->s, 0, SEEK_END) < 0)
288 if (flags->access != ACCESS_STREAM)
289 u->current_record = 0;
291 u->endfile = AT_ENDFILE; /* We are at the end. */
295 generate_error (&opp->common, LIBERROR_OS, NULL);
303 /* Open an unused unit. */
306 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
310 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
312 /* Change unspecifieds to defaults. Leave (flags->action ==
313 ACTION_UNSPECIFIED) alone so open_external() can set it based on
314 what type of open actually works. */
316 if (flags->access == ACCESS_UNSPECIFIED)
317 flags->access = ACCESS_SEQUENTIAL;
319 if (flags->form == FORM_UNSPECIFIED)
320 flags->form = (flags->access == ACCESS_SEQUENTIAL)
321 ? FORM_FORMATTED : FORM_UNFORMATTED;
323 if (flags->async == ASYNC_UNSPECIFIED)
324 flags->async = ASYNC_NO;
326 if (flags->status == STATUS_UNSPECIFIED)
327 flags->status = STATUS_UNKNOWN;
331 if (flags->delim == DELIM_UNSPECIFIED)
332 flags->delim = DELIM_NONE;
335 if (flags->form == FORM_UNFORMATTED)
337 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
338 "DELIM parameter conflicts with UNFORMATTED form in "
344 if (flags->blank == BLANK_UNSPECIFIED)
345 flags->blank = BLANK_NULL;
348 if (flags->form == FORM_UNFORMATTED)
350 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
351 "BLANK parameter conflicts with UNFORMATTED form in "
357 if (flags->pad == PAD_UNSPECIFIED)
358 flags->pad = PAD_YES;
361 if (flags->form == FORM_UNFORMATTED)
363 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
364 "PAD parameter conflicts with UNFORMATTED form in "
370 if (flags->decimal == DECIMAL_UNSPECIFIED)
371 flags->decimal = DECIMAL_POINT;
374 if (flags->form == FORM_UNFORMATTED)
376 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
377 "DECIMAL parameter conflicts with UNFORMATTED form "
378 "in OPEN statement");
383 if (flags->encoding == ENCODING_UNSPECIFIED)
384 flags->encoding = ENCODING_DEFAULT;
387 if (flags->form == FORM_UNFORMATTED)
389 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
390 "ENCODING parameter conflicts with UNFORMATTED form in "
396 /* NB: the value for ROUND when it's not specified by the user does not
397 have to be PROCESSOR_DEFINED; the standard says that it is
398 processor dependent, and requires that it is one of the
399 possible value (see F2003, 9.4.5.13). */
400 if (flags->round == ROUND_UNSPECIFIED)
401 flags->round = ROUND_PROCDEFINED;
404 if (flags->form == FORM_UNFORMATTED)
406 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
407 "ROUND parameter conflicts with UNFORMATTED form in "
413 if (flags->sign == SIGN_UNSPECIFIED)
414 flags->sign = SIGN_PROCDEFINED;
417 if (flags->form == FORM_UNFORMATTED)
419 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
420 "SIGN parameter conflicts with UNFORMATTED form in "
426 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
428 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
429 "ACCESS parameter conflicts with SEQUENTIAL access in "
434 if (flags->position == POSITION_UNSPECIFIED)
435 flags->position = POSITION_ASIS;
437 if (flags->access == ACCESS_DIRECT
438 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
440 generate_error (&opp->common, LIBERROR_MISSING_OPTION,
441 "Missing RECL parameter in OPEN statement");
445 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
447 generate_error (&opp->common, LIBERROR_BAD_OPTION,
448 "RECL parameter is non-positive in OPEN statement");
452 switch (flags->status)
455 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
461 generate_error (&opp->common, LIBERROR_BAD_OPTION,
462 "FILE parameter must not be present in OPEN statement");
469 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
473 opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
474 (int) opp->common.unit);
478 internal_error (&opp->common, "new_unit(): Bad status");
481 /* Make sure the file isn't already open someplace else.
482 Do not error if opening file preconnected to stdin, stdout, stderr. */
485 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
486 u2 = find_file (opp->file, opp->file_len);
488 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
489 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
490 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
493 generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
502 s = open_external (opp, flags);
507 path = (char *) gfc_alloca (opp->file_len + 1);
508 msglen = opp->file_len + 51;
509 msg = (char *) gfc_alloca (msglen);
510 unpack_filename (path, opp->file, opp->file_len);
515 snprintf (msg, msglen, "File '%s' does not exist", path);
519 snprintf (msg, msglen, "File '%s' already exists", path);
523 snprintf (msg, msglen,
524 "Permission denied trying to open file '%s'", path);
528 snprintf (msg, msglen, "'%s' is a directory", path);
535 generate_error (&opp->common, LIBERROR_OS, msg);
539 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
540 flags->status = STATUS_OLD;
542 /* Create the unit structure. */
544 u->file = xmalloc (opp->file_len);
545 if (u->unit_number != opp->common.unit)
546 internal_error (&opp->common, "Unit number changed");
550 u->endfile = NO_ENDFILE;
552 u->current_record = 0;
558 if (flags->position == POSITION_APPEND)
560 if (sseek (u->s, 0, SEEK_END) < 0)
561 generate_error (&opp->common, LIBERROR_OS, NULL);
562 u->endfile = AT_ENDFILE;
565 /* Unspecified recl ends up with a processor dependent value. */
567 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
569 u->flags.has_recl = 1;
570 u->recl = opp->recl_in;
571 u->recl_subrecord = u->recl;
572 u->bytes_left = u->recl;
576 u->flags.has_recl = 0;
577 u->recl = max_offset;
578 if (compile_options.max_subrecord_length)
580 u->recl_subrecord = compile_options.max_subrecord_length;
584 switch (compile_options.record_marker)
588 case sizeof (GFC_INTEGER_4):
589 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
592 case sizeof (GFC_INTEGER_8):
593 u->recl_subrecord = max_offset - 16;
597 runtime_error ("Illegal value for record marker");
603 /* If the file is direct access, calculate the maximum record number
604 via a division now instead of letting the multiplication overflow
607 if (flags->access == ACCESS_DIRECT)
608 u->maxrec = max_offset / u->recl;
610 if (flags->access == ACCESS_STREAM)
612 u->maxrec = max_offset;
615 u->strm_pos = stell (u->s) + 1;
618 memmove (u->file, opp->file, opp->file_len);
619 u->file_len = opp->file_len;
621 /* Curiously, the standard requires that the
622 position specifier be ignored for new files so a newly connected
623 file starts out at the initial point. We still need to figure
624 out if the file is at the end or not. */
628 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
631 if (flags->form == FORM_FORMATTED)
633 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
634 fbuf_init (u, u->recl);
647 /* Free memory associated with a temporary filename. */
649 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
659 /* Open a unit which is already open. This involves changing the
660 modes or closing what is there now and opening the new file. */
663 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
665 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
667 edit_modes (opp, u, flags);
671 /* If the file is connected to something else, close it and open a
674 if (!compare_file_filename (u, opp->file, opp->file_len))
676 #if !HAVE_UNLINK_OPEN_FILE
678 if (u->file && u->flags.status == STATUS_SCRATCH)
680 path = (char *) gfc_alloca (u->file_len + 1);
681 unpack_filename (path, u->file, u->file_len);
685 if (sclose (u->s) == -1)
688 generate_error (&opp->common, LIBERROR_OS,
689 "Error closing file in OPEN statement");
698 #if !HAVE_UNLINK_OPEN_FILE
703 u = new_unit (opp, u, flags);
709 edit_modes (opp, u, flags);
715 extern void st_open (st_parameter_open *opp);
716 export_proto(st_open);
719 st_open (st_parameter_open *opp)
723 GFC_INTEGER_4 cf = opp->common.flags;
726 library_start (&opp->common);
728 /* Decode options. */
730 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
731 find_option (&opp->common, opp->access, opp->access_len,
732 access_opt, "Bad ACCESS parameter in OPEN statement");
734 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
735 find_option (&opp->common, opp->action, opp->action_len,
736 action_opt, "Bad ACTION parameter in OPEN statement");
738 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
739 find_option (&opp->common, opp->blank, opp->blank_len,
740 blank_opt, "Bad BLANK parameter in OPEN statement");
742 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
743 find_option (&opp->common, opp->delim, opp->delim_len,
744 delim_opt, "Bad DELIM parameter in OPEN statement");
746 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
747 find_option (&opp->common, opp->pad, opp->pad_len,
748 pad_opt, "Bad PAD parameter in OPEN statement");
750 flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
751 find_option (&opp->common, opp->decimal, opp->decimal_len,
752 decimal_opt, "Bad DECIMAL parameter in OPEN statement");
754 flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
755 find_option (&opp->common, opp->encoding, opp->encoding_len,
756 encoding_opt, "Bad ENCODING parameter in OPEN statement");
758 flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
759 find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
760 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
762 flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
763 find_option (&opp->common, opp->round, opp->round_len,
764 round_opt, "Bad ROUND parameter in OPEN statement");
766 flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
767 find_option (&opp->common, opp->sign, opp->sign_len,
768 sign_opt, "Bad SIGN parameter in OPEN statement");
770 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
771 find_option (&opp->common, opp->form, opp->form_len,
772 form_opt, "Bad FORM parameter in OPEN statement");
774 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
775 find_option (&opp->common, opp->position, opp->position_len,
776 position_opt, "Bad POSITION parameter in OPEN statement");
778 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
779 find_option (&opp->common, opp->status, opp->status_len,
780 status_opt, "Bad STATUS parameter in OPEN statement");
782 /* First, we check wether the convert flag has been set via environment
783 variable. This overrides the convert tag in the open statement. */
785 conv = get_unformatted_convert (opp->common.unit);
787 if (conv == GFC_CONVERT_NONE)
789 /* Nothing has been set by environment variable, check the convert tag. */
790 if (cf & IOPARM_OPEN_HAS_CONVERT)
791 conv = find_option (&opp->common, opp->convert, opp->convert_len,
793 "Bad CONVERT parameter in OPEN statement");
795 conv = compile_options.convert;
798 /* We use big_endian, which is 0 on little-endian machines
799 and 1 on big-endian machines. */
802 case GFC_CONVERT_NATIVE:
803 case GFC_CONVERT_SWAP:
806 case GFC_CONVERT_BIG:
807 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
810 case GFC_CONVERT_LITTLE:
811 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
815 internal_error (&opp->common, "Illegal value for CONVERT");
819 flags.convert = conv;
821 if (!(opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) && opp->common.unit < 0)
822 generate_error (&opp->common, LIBERROR_BAD_OPTION,
823 "Bad unit number in OPEN statement");
825 if (flags.position != POSITION_UNSPECIFIED
826 && flags.access == ACCESS_DIRECT)
827 generate_error (&opp->common, LIBERROR_BAD_OPTION,
828 "Cannot use POSITION with direct access files");
830 if (flags.access == ACCESS_APPEND)
832 if (flags.position != POSITION_UNSPECIFIED
833 && flags.position != POSITION_APPEND)
834 generate_error (&opp->common, LIBERROR_BAD_OPTION,
835 "Conflicting ACCESS and POSITION flags in"
838 notify_std (&opp->common, GFC_STD_GNU,
839 "Extension: APPEND as a value for ACCESS in OPEN statement");
840 flags.access = ACCESS_SEQUENTIAL;
841 flags.position = POSITION_APPEND;
844 if (flags.position == POSITION_UNSPECIFIED)
845 flags.position = POSITION_ASIS;
847 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
849 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
850 opp->common.unit = get_unique_unit_number(opp);
852 u = find_or_create_unit (opp->common.unit);
855 u = new_unit (opp, u, &flags);
860 already_open (opp, u, &flags);
863 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
864 && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
865 *opp->newunit = opp->common.unit;