1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
38 static const st_option access_opt[] = {
39 {"sequential", ACCESS_SEQUENTIAL},
40 {"direct", ACCESS_DIRECT},
41 {"append", ACCESS_APPEND},
42 {"stream", ACCESS_STREAM},
46 static const st_option action_opt[] =
48 { "read", ACTION_READ},
49 { "write", ACTION_WRITE},
50 { "readwrite", ACTION_READWRITE},
54 static const st_option blank_opt[] =
56 { "null", BLANK_NULL},
57 { "zero", BLANK_ZERO},
61 static const st_option delim_opt[] =
63 { "none", DELIM_NONE},
64 { "apostrophe", DELIM_APOSTROPHE},
65 { "quote", DELIM_QUOTE},
69 static const st_option form_opt[] =
71 { "formatted", FORM_FORMATTED},
72 { "unformatted", FORM_UNFORMATTED},
76 static const st_option position_opt[] =
78 { "asis", POSITION_ASIS},
79 { "rewind", POSITION_REWIND},
80 { "append", POSITION_APPEND},
84 static const st_option status_opt[] =
86 { "unknown", STATUS_UNKNOWN},
89 { "replace", STATUS_REPLACE},
90 { "scratch", STATUS_SCRATCH},
94 static const st_option pad_opt[] =
101 static const st_option decimal_opt[] =
103 { "point", DECIMAL_POINT},
104 { "comma", DECIMAL_COMMA},
108 static const st_option encoding_opt[] =
110 { "utf-8", ENCODING_UTF8},
111 { "default", ENCODING_DEFAULT},
115 static const st_option round_opt[] =
118 { "down", ROUND_DOWN},
119 { "zero", ROUND_ZERO},
120 { "nearest", ROUND_NEAREST},
121 { "compatible", ROUND_COMPATIBLE},
122 { "processor_defined", ROUND_PROCDEFINED},
126 static const st_option sign_opt[] =
128 { "plus", SIGN_PLUS},
129 { "suppress", SIGN_SUPPRESS},
130 { "processor_defined", SIGN_PROCDEFINED},
134 static const st_option convert_opt[] =
136 { "native", GFC_CONVERT_NATIVE},
137 { "swap", GFC_CONVERT_SWAP},
138 { "big_endian", GFC_CONVERT_BIG},
139 { "little_endian", GFC_CONVERT_LITTLE},
143 static const st_option async_opt[] =
150 /* Given a unit, test to see if the file is positioned at the terminal
151 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
152 This prevents us from changing the state from AFTER_ENDFILE to
156 test_endfile (gfc_unit * u)
158 if (u->endfile == NO_ENDFILE && file_length (u->s) == stell (u->s))
159 u->endfile = AT_ENDFILE;
163 /* Change the modes of a file, those that are allowed * to be
167 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
169 /* Complain about attempts to change the unchangeable. */
171 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
172 u->flags.status != flags->status)
173 generate_error (&opp->common, LIBERROR_BAD_OPTION,
174 "Cannot change STATUS parameter in OPEN statement");
176 if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
177 generate_error (&opp->common, LIBERROR_BAD_OPTION,
178 "Cannot change ACCESS parameter in OPEN statement");
180 if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
181 generate_error (&opp->common, LIBERROR_BAD_OPTION,
182 "Cannot change FORM parameter in OPEN statement");
184 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
185 && opp->recl_in != u->recl)
186 generate_error (&opp->common, LIBERROR_BAD_OPTION,
187 "Cannot change RECL parameter in OPEN statement");
189 if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
190 generate_error (&opp->common, LIBERROR_BAD_OPTION,
191 "Cannot change ACTION parameter in OPEN statement");
193 /* Status must be OLD if present. */
195 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
196 flags->status != STATUS_UNKNOWN)
198 if (flags->status == STATUS_SCRATCH)
199 notify_std (&opp->common, GFC_STD_GNU,
200 "OPEN statement must have a STATUS of OLD or UNKNOWN");
202 generate_error (&opp->common, LIBERROR_BAD_OPTION,
203 "OPEN statement must have a STATUS of OLD or UNKNOWN");
206 if (u->flags.form == FORM_UNFORMATTED)
208 if (flags->delim != DELIM_UNSPECIFIED)
209 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
210 "DELIM parameter conflicts with UNFORMATTED form in "
213 if (flags->blank != BLANK_UNSPECIFIED)
214 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
215 "BLANK parameter conflicts with UNFORMATTED form in "
218 if (flags->pad != PAD_UNSPECIFIED)
219 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
220 "PAD parameter conflicts with UNFORMATTED form in "
223 if (flags->decimal != DECIMAL_UNSPECIFIED)
224 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
225 "DECIMAL parameter conflicts with UNFORMATTED form in "
228 if (flags->encoding != ENCODING_UNSPECIFIED)
229 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
230 "ENCODING parameter conflicts with UNFORMATTED form in "
233 if (flags->round != ROUND_UNSPECIFIED)
234 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
235 "ROUND parameter conflicts with UNFORMATTED form in "
238 if (flags->sign != SIGN_UNSPECIFIED)
239 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
240 "SIGN parameter conflicts with UNFORMATTED form in "
244 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
246 /* Change the changeable: */
247 if (flags->blank != BLANK_UNSPECIFIED)
248 u->flags.blank = flags->blank;
249 if (flags->delim != DELIM_UNSPECIFIED)
250 u->flags.delim = flags->delim;
251 if (flags->pad != PAD_UNSPECIFIED)
252 u->flags.pad = flags->pad;
253 if (flags->decimal != DECIMAL_UNSPECIFIED)
254 u->flags.decimal = flags->decimal;
255 if (flags->encoding != ENCODING_UNSPECIFIED)
256 u->flags.encoding = flags->encoding;
257 if (flags->async != ASYNC_UNSPECIFIED)
258 u->flags.async = flags->async;
259 if (flags->round != ROUND_UNSPECIFIED)
260 u->flags.round = flags->round;
261 if (flags->sign != SIGN_UNSPECIFIED)
262 u->flags.sign = flags->sign;
265 /* Reposition the file if necessary. */
267 switch (flags->position)
269 case POSITION_UNSPECIFIED:
273 case POSITION_REWIND:
274 if (sseek (u->s, 0, SEEK_SET) != 0)
277 u->current_record = 0;
283 case POSITION_APPEND:
284 if (sseek (u->s, 0, SEEK_END) < 0)
287 if (flags->access != ACCESS_STREAM)
288 u->current_record = 0;
290 u->endfile = AT_ENDFILE; /* We are at the end. */
294 generate_error (&opp->common, LIBERROR_OS, NULL);
302 /* Open an unused unit. */
305 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
309 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
311 /* Change unspecifieds to defaults. Leave (flags->action ==
312 ACTION_UNSPECIFIED) alone so open_external() can set it based on
313 what type of open actually works. */
315 if (flags->access == ACCESS_UNSPECIFIED)
316 flags->access = ACCESS_SEQUENTIAL;
318 if (flags->form == FORM_UNSPECIFIED)
319 flags->form = (flags->access == ACCESS_SEQUENTIAL)
320 ? FORM_FORMATTED : FORM_UNFORMATTED;
322 if (flags->async == ASYNC_UNSPECIFIED)
323 flags->async = ASYNC_NO;
325 if (flags->status == STATUS_UNSPECIFIED)
326 flags->status = STATUS_UNKNOWN;
330 if (flags->delim == DELIM_UNSPECIFIED)
331 flags->delim = DELIM_NONE;
334 if (flags->form == FORM_UNFORMATTED)
336 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
337 "DELIM parameter conflicts with UNFORMATTED form in "
343 if (flags->blank == BLANK_UNSPECIFIED)
344 flags->blank = BLANK_NULL;
347 if (flags->form == FORM_UNFORMATTED)
349 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
350 "BLANK parameter conflicts with UNFORMATTED form in "
356 if (flags->pad == PAD_UNSPECIFIED)
357 flags->pad = PAD_YES;
360 if (flags->form == FORM_UNFORMATTED)
362 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
363 "PAD parameter conflicts with UNFORMATTED form in "
369 if (flags->decimal == DECIMAL_UNSPECIFIED)
370 flags->decimal = DECIMAL_POINT;
373 if (flags->form == FORM_UNFORMATTED)
375 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
376 "DECIMAL parameter conflicts with UNFORMATTED form "
377 "in OPEN statement");
382 if (flags->encoding == ENCODING_UNSPECIFIED)
383 flags->encoding = ENCODING_DEFAULT;
386 if (flags->form == FORM_UNFORMATTED)
388 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
389 "ENCODING parameter conflicts with UNFORMATTED form in "
395 /* NB: the value for ROUND when it's not specified by the user does not
396 have to be PROCESSOR_DEFINED; the standard says that it is
397 processor dependent, and requires that it is one of the
398 possible value (see F2003, 9.4.5.13). */
399 if (flags->round == ROUND_UNSPECIFIED)
400 flags->round = ROUND_PROCDEFINED;
403 if (flags->form == FORM_UNFORMATTED)
405 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
406 "ROUND parameter conflicts with UNFORMATTED form in "
412 if (flags->sign == SIGN_UNSPECIFIED)
413 flags->sign = SIGN_PROCDEFINED;
416 if (flags->form == FORM_UNFORMATTED)
418 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
419 "SIGN parameter conflicts with UNFORMATTED form in "
425 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
427 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
428 "ACCESS parameter conflicts with SEQUENTIAL access in "
433 if (flags->position == POSITION_UNSPECIFIED)
434 flags->position = POSITION_ASIS;
436 if (flags->access == ACCESS_DIRECT
437 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
439 generate_error (&opp->common, LIBERROR_MISSING_OPTION,
440 "Missing RECL parameter in OPEN statement");
444 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
446 generate_error (&opp->common, LIBERROR_BAD_OPTION,
447 "RECL parameter is non-positive in OPEN statement");
451 switch (flags->status)
454 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
460 generate_error (&opp->common, LIBERROR_BAD_OPTION,
461 "FILE parameter must not be present in OPEN statement");
468 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
473 opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
474 (int) opp->common.unit);
476 opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
481 internal_error (&opp->common, "new_unit(): Bad status");
484 /* Make sure the file isn't already open someplace else.
485 Do not error if opening file preconnected to stdin, stdout, stderr. */
488 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
489 u2 = find_file (opp->file, opp->file_len);
491 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
492 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
493 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
496 generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
505 s = open_external (opp, flags);
509 path = (char *) gfc_alloca (opp->file_len + 1);
510 msg = (char *) gfc_alloca (opp->file_len + 51);
511 unpack_filename (path, opp->file, opp->file_len);
516 sprintf (msg, "File '%s' does not exist", path);
520 sprintf (msg, "File '%s' already exists", path);
524 sprintf (msg, "Permission denied trying to open file '%s'", path);
528 sprintf (msg, "'%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 = get_mem (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)
629 free_mem (opp->file);
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)
650 free_mem (opp->file);
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) == FAILURE)
688 generate_error (&opp->common, LIBERROR_OS,
689 "Error closing file in OPEN statement");
699 #if !HAVE_UNLINK_OPEN_FILE
704 u = new_unit (opp, u, flags);
710 edit_modes (opp, u, flags);
716 extern void st_open (st_parameter_open *opp);
717 export_proto(st_open);
720 st_open (st_parameter_open *opp)
724 GFC_INTEGER_4 cf = opp->common.flags;
727 library_start (&opp->common);
729 /* Decode options. */
731 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
732 find_option (&opp->common, opp->access, opp->access_len,
733 access_opt, "Bad ACCESS parameter in OPEN statement");
735 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
736 find_option (&opp->common, opp->action, opp->action_len,
737 action_opt, "Bad ACTION parameter in OPEN statement");
739 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
740 find_option (&opp->common, opp->blank, opp->blank_len,
741 blank_opt, "Bad BLANK parameter in OPEN statement");
743 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
744 find_option (&opp->common, opp->delim, opp->delim_len,
745 delim_opt, "Bad DELIM parameter in OPEN statement");
747 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
748 find_option (&opp->common, opp->pad, opp->pad_len,
749 pad_opt, "Bad PAD parameter in OPEN statement");
751 flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
752 find_option (&opp->common, opp->decimal, opp->decimal_len,
753 decimal_opt, "Bad DECIMAL parameter in OPEN statement");
755 flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
756 find_option (&opp->common, opp->encoding, opp->encoding_len,
757 encoding_opt, "Bad ENCODING parameter in OPEN statement");
759 flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
760 find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
761 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
763 flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
764 find_option (&opp->common, opp->round, opp->round_len,
765 round_opt, "Bad ROUND parameter in OPEN statement");
767 flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
768 find_option (&opp->common, opp->sign, opp->sign_len,
769 sign_opt, "Bad SIGN parameter in OPEN statement");
771 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
772 find_option (&opp->common, opp->form, opp->form_len,
773 form_opt, "Bad FORM parameter in OPEN statement");
775 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
776 find_option (&opp->common, opp->position, opp->position_len,
777 position_opt, "Bad POSITION parameter in OPEN statement");
779 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
780 find_option (&opp->common, opp->status, opp->status_len,
781 status_opt, "Bad STATUS parameter in OPEN statement");
783 /* First, we check wether the convert flag has been set via environment
784 variable. This overrides the convert tag in the open statement. */
786 conv = get_unformatted_convert (opp->common.unit);
788 if (conv == GFC_CONVERT_NONE)
790 /* Nothing has been set by environment variable, check the convert tag. */
791 if (cf & IOPARM_OPEN_HAS_CONVERT)
792 conv = find_option (&opp->common, opp->convert, opp->convert_len,
794 "Bad CONVERT parameter in OPEN statement");
796 conv = compile_options.convert;
799 /* We use big_endian, which is 0 on little-endian machines
800 and 1 on big-endian machines. */
803 case GFC_CONVERT_NATIVE:
804 case GFC_CONVERT_SWAP:
807 case GFC_CONVERT_BIG:
808 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
811 case GFC_CONVERT_LITTLE:
812 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
816 internal_error (&opp->common, "Illegal value for CONVERT");
820 flags.convert = conv;
822 if (opp->common.unit < 0)
823 generate_error (&opp->common, LIBERROR_BAD_OPTION,
824 "Bad unit number in OPEN statement");
826 if (flags.position != POSITION_UNSPECIFIED
827 && flags.access == ACCESS_DIRECT)
828 generate_error (&opp->common, LIBERROR_BAD_OPTION,
829 "Cannot use POSITION with direct access files");
831 if (flags.access == ACCESS_APPEND)
833 if (flags.position != POSITION_UNSPECIFIED
834 && flags.position != POSITION_APPEND)
835 generate_error (&opp->common, LIBERROR_BAD_OPTION,
836 "Conflicting ACCESS and POSITION flags in"
839 notify_std (&opp->common, GFC_STD_GNU,
840 "Extension: APPEND as a value for ACCESS in OPEN statement");
841 flags.access = ACCESS_SEQUENTIAL;
842 flags.position = POSITION_APPEND;
845 if (flags.position == POSITION_UNSPECIFIED)
846 flags.position = POSITION_ASIS;
848 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
850 u = find_or_create_unit (opp->common.unit);
854 u = new_unit (opp, u, &flags);
859 already_open (opp, u, &flags);