1 /* Copyright (C) 2002, 2003, 2004, 2005
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 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 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
36 #include "libgfortran.h"
40 static const st_option access_opt[] = {
41 {"sequential", ACCESS_SEQUENTIAL},
42 {"direct", ACCESS_DIRECT},
43 {"append", ACCESS_APPEND},
44 {"stream", ACCESS_STREAM},
48 static const st_option action_opt[] =
50 { "read", ACTION_READ},
51 { "write", ACTION_WRITE},
52 { "readwrite", ACTION_READWRITE},
56 static const st_option blank_opt[] =
58 { "null", BLANK_NULL},
59 { "zero", BLANK_ZERO},
63 static const st_option delim_opt[] =
65 { "none", DELIM_NONE},
66 { "apostrophe", DELIM_APOSTROPHE},
67 { "quote", DELIM_QUOTE},
71 static const st_option form_opt[] =
73 { "formatted", FORM_FORMATTED},
74 { "unformatted", FORM_UNFORMATTED},
78 static const st_option position_opt[] =
80 { "asis", POSITION_ASIS},
81 { "rewind", POSITION_REWIND},
82 { "append", POSITION_APPEND},
86 static const st_option status_opt[] =
88 { "unknown", STATUS_UNKNOWN},
91 { "replace", STATUS_REPLACE},
92 { "scratch", STATUS_SCRATCH},
96 static const st_option pad_opt[] =
103 static const st_option convert_opt[] =
105 { "native", CONVERT_NATIVE},
106 { "swap", CONVERT_SWAP},
107 { "big_endian", CONVERT_BIG},
108 { "little_endian", CONVERT_LITTLE},
112 /* Given a unit, test to see if the file is positioned at the terminal
113 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
114 This prevents us from changing the state from AFTER_ENDFILE to
118 test_endfile (gfc_unit * u)
120 if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
121 u->endfile = AT_ENDFILE;
125 /* Change the modes of a file, those that are allowed * to be
129 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
131 /* Complain about attempts to change the unchangeable. */
133 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
134 u->flags.status != flags->status)
135 generate_error (&opp->common, ERROR_BAD_OPTION,
136 "Cannot change STATUS parameter in OPEN statement");
138 if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
139 generate_error (&opp->common, ERROR_BAD_OPTION,
140 "Cannot change ACCESS parameter in OPEN statement");
142 if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
143 generate_error (&opp->common, ERROR_BAD_OPTION,
144 "Cannot change FORM parameter in OPEN statement");
146 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
147 && opp->recl_in != u->recl)
148 generate_error (&opp->common, ERROR_BAD_OPTION,
149 "Cannot change RECL parameter in OPEN statement");
151 if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
152 generate_error (&opp->common, ERROR_BAD_OPTION,
153 "Cannot change ACTION parameter in OPEN statement");
155 /* Status must be OLD if present. */
157 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
158 flags->status != STATUS_UNKNOWN)
160 if (flags->status == STATUS_SCRATCH)
161 notify_std (&opp->common, GFC_STD_GNU,
162 "OPEN statement must have a STATUS of OLD or UNKNOWN");
164 generate_error (&opp->common, ERROR_BAD_OPTION,
165 "OPEN statement must have a STATUS of OLD or UNKNOWN");
168 if (u->flags.form == FORM_UNFORMATTED)
170 if (flags->delim != DELIM_UNSPECIFIED)
171 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
172 "DELIM parameter conflicts with UNFORMATTED form in "
175 if (flags->blank != BLANK_UNSPECIFIED)
176 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
177 "BLANK parameter conflicts with UNFORMATTED form in "
180 if (flags->pad != PAD_UNSPECIFIED)
181 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
182 "PAD parameter conflicts with UNFORMATTED form in "
186 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
188 /* Change the changeable: */
189 if (flags->blank != BLANK_UNSPECIFIED)
190 u->flags.blank = flags->blank;
191 if (flags->delim != DELIM_UNSPECIFIED)
192 u->flags.delim = flags->delim;
193 if (flags->pad != PAD_UNSPECIFIED)
194 u->flags.pad = flags->pad;
197 /* Reposition the file if necessary. */
199 switch (flags->position)
201 case POSITION_UNSPECIFIED:
205 case POSITION_REWIND:
206 if (sseek (u->s, 0) == FAILURE)
209 u->current_record = 0;
212 test_endfile (u); /* We might be at the end. */
215 case POSITION_APPEND:
216 if (sseek (u->s, file_length (u->s)) == FAILURE)
219 if (flags->access != ACCESS_STREAM)
220 u->current_record = 0;
222 u->endfile = AT_ENDFILE; /* We are at the end. */
226 generate_error (&opp->common, ERROR_OS, NULL);
234 /* Open an unused unit. */
237 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
241 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
243 /* Change unspecifieds to defaults. Leave (flags->action ==
244 ACTION_UNSPECIFIED) alone so open_external() can set it based on
245 what type of open actually works. */
247 if (flags->access == ACCESS_UNSPECIFIED)
248 flags->access = ACCESS_SEQUENTIAL;
250 if (flags->form == FORM_UNSPECIFIED)
251 flags->form = (flags->access == ACCESS_SEQUENTIAL)
252 ? FORM_FORMATTED : FORM_UNFORMATTED;
255 if (flags->delim == DELIM_UNSPECIFIED)
256 flags->delim = DELIM_NONE;
259 if (flags->form == FORM_UNFORMATTED)
261 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
262 "DELIM parameter conflicts with UNFORMATTED form in "
268 if (flags->blank == BLANK_UNSPECIFIED)
269 flags->blank = BLANK_NULL;
272 if (flags->form == FORM_UNFORMATTED)
274 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
275 "BLANK parameter conflicts with UNFORMATTED form in "
281 if (flags->pad == PAD_UNSPECIFIED)
282 flags->pad = PAD_YES;
285 if (flags->form == FORM_UNFORMATTED)
287 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
288 "PAD parameter conflicts with UNFORMATTED form in "
294 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
296 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
297 "ACCESS parameter conflicts with SEQUENTIAL access in "
302 if (flags->position == POSITION_UNSPECIFIED)
303 flags->position = POSITION_ASIS;
306 if (flags->status == STATUS_UNSPECIFIED)
307 flags->status = STATUS_UNKNOWN;
311 if (flags->access == ACCESS_DIRECT
312 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
314 generate_error (&opp->common, ERROR_MISSING_OPTION,
315 "Missing RECL parameter in OPEN statement");
319 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
321 generate_error (&opp->common, ERROR_BAD_OPTION,
322 "RECL parameter is non-positive in OPEN statement");
326 switch (flags->status)
329 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
335 generate_error (&opp->common, ERROR_BAD_OPTION,
336 "FILE parameter must not be present in OPEN statement");
343 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
347 opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
351 internal_error (&opp->common, "new_unit(): Bad status");
354 /* Make sure the file isn't already open someplace else.
355 Do not error if opening file preconnected to stdin, stdout, stderr. */
358 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
359 u2 = find_file (opp->file, opp->file_len);
361 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
362 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
363 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
366 generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
375 s = open_external (opp, flags);
379 path = (char *) gfc_alloca (opp->file_len + 1);
380 msg = (char *) gfc_alloca (opp->file_len + 51);
381 unpack_filename (path, opp->file, opp->file_len);
386 st_sprintf (msg, "File '%s' does not exist", path);
390 st_sprintf (msg, "File '%s' already exists", path);
394 st_sprintf (msg, "Permission denied trying to open file '%s'", path);
398 st_sprintf (msg, "'%s' is a directory", path);
405 generate_error (&opp->common, ERROR_OS, msg);
409 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
410 flags->status = STATUS_OLD;
412 /* Create the unit structure. */
414 u->file = get_mem (opp->file_len);
415 if (u->unit_number != opp->common.unit)
416 internal_error (&opp->common, "Unit number changed");
420 u->endfile = NO_ENDFILE;
422 u->current_record = 0;
427 if (flags->position == POSITION_APPEND)
429 if (sseek (u->s, file_length (u->s)) == FAILURE)
430 generate_error (&opp->common, ERROR_OS, NULL);
431 u->endfile = AT_ENDFILE;
434 /* Unspecified recl ends up with a processor dependent value. */
436 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
438 u->flags.has_recl = 1;
439 u->recl = opp->recl_in;
443 u->flags.has_recl = 0;
444 u->recl = max_offset;
445 if (compile_options.max_subrecord_length)
447 u->recl_subrecord = compile_options.max_subrecord_length;
451 switch (compile_options.record_marker)
455 case sizeof (GFC_INTEGER_4):
456 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
459 case sizeof (GFC_INTEGER_8):
460 u->recl_subrecord = max_offset - 16;
464 runtime_error ("Illegal value for record marker");
470 /* If the file is direct access, calculate the maximum record number
471 via a division now instead of letting the multiplication overflow
474 if (flags->access == ACCESS_DIRECT)
475 u->maxrec = max_offset / u->recl;
477 if (flags->access == ACCESS_STREAM)
479 u->maxrec = max_offset;
484 memmove (u->file, opp->file, opp->file_len);
485 u->file_len = opp->file_len;
487 /* Curiously, the standard requires that the
488 position specifier be ignored for new files so a newly connected
489 file starts out that the initial point. We still need to figure
490 out if the file is at the end or not. */
494 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
495 free_mem (opp->file);
500 /* Free memory associated with a temporary filename. */
502 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
503 free_mem (opp->file);
512 /* Open a unit which is already open. This involves changing the
513 modes or closing what is there now and opening the new file. */
516 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
518 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
520 edit_modes (opp, u, flags);
524 /* If the file is connected to something else, close it and open a
527 if (!compare_file_filename (u, opp->file, opp->file_len))
529 #if !HAVE_UNLINK_OPEN_FILE
531 if (u->file && u->flags.status == STATUS_SCRATCH)
533 path = (char *) gfc_alloca (u->file_len + 1);
534 unpack_filename (path, u->file, u->file_len);
538 if (sclose (u->s) == FAILURE)
541 generate_error (&opp->common, ERROR_OS,
542 "Error closing file in OPEN statement");
552 #if !HAVE_UNLINK_OPEN_FILE
557 u = new_unit (opp, u, flags);
563 edit_modes (opp, u, flags);
569 extern void st_open (st_parameter_open *opp);
570 export_proto(st_open);
573 st_open (st_parameter_open *opp)
577 GFC_INTEGER_4 cf = opp->common.flags;
580 library_start (&opp->common);
582 /* Decode options. */
584 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
585 find_option (&opp->common, opp->access, opp->access_len,
586 access_opt, "Bad ACCESS parameter in OPEN statement");
588 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
589 find_option (&opp->common, opp->action, opp->action_len,
590 action_opt, "Bad ACTION parameter in OPEN statement");
592 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
593 find_option (&opp->common, opp->blank, opp->blank_len,
594 blank_opt, "Bad BLANK parameter in OPEN statement");
596 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
597 find_option (&opp->common, opp->delim, opp->delim_len,
598 delim_opt, "Bad DELIM parameter in OPEN statement");
600 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
601 find_option (&opp->common, opp->pad, opp->pad_len,
602 pad_opt, "Bad PAD parameter in OPEN statement");
604 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
605 find_option (&opp->common, opp->form, opp->form_len,
606 form_opt, "Bad FORM parameter in OPEN statement");
608 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
609 find_option (&opp->common, opp->position, opp->position_len,
610 position_opt, "Bad POSITION parameter in OPEN statement");
612 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
613 find_option (&opp->common, opp->status, opp->status_len,
614 status_opt, "Bad STATUS parameter in OPEN statement");
616 /* First, we check wether the convert flag has been set via environment
617 variable. This overrides the convert tag in the open statement. */
619 conv = get_unformatted_convert (opp->common.unit);
621 if (conv == CONVERT_NONE)
623 /* Nothing has been set by environment variable, check the convert tag. */
624 if (cf & IOPARM_OPEN_HAS_CONVERT)
625 conv = find_option (&opp->common, opp->convert, opp->convert_len,
627 "Bad CONVERT parameter in OPEN statement");
629 conv = compile_options.convert;
632 /* We use l8_to_l4_offset, which is 0 on little-endian machines
633 and 1 on big-endian machines. */
641 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
645 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
649 internal_error (&opp->common, "Illegal value for CONVERT");
653 flags.convert = conv;
655 if (opp->common.unit < 0)
656 generate_error (&opp->common, ERROR_BAD_OPTION,
657 "Bad unit number in OPEN statement");
659 if (flags.position != POSITION_UNSPECIFIED
660 && flags.access == ACCESS_DIRECT)
661 generate_error (&opp->common, ERROR_BAD_OPTION,
662 "Cannot use POSITION with direct access files");
664 if (flags.access == ACCESS_APPEND)
666 if (flags.position != POSITION_UNSPECIFIED
667 && flags.position != POSITION_APPEND)
668 generate_error (&opp->common, ERROR_BAD_OPTION,
669 "Conflicting ACCESS and POSITION flags in"
672 notify_std (&opp->common, GFC_STD_GNU,
673 "Extension: APPEND as a value for ACCESS in OPEN statement");
674 flags.access = ACCESS_SEQUENTIAL;
675 flags.position = POSITION_APPEND;
678 if (flags.position == POSITION_UNSPECIFIED)
679 flags.position = POSITION_ASIS;
681 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
683 u = find_or_create_unit (opp->common.unit);
687 u = new_unit (opp, u, &flags);
692 already_open (opp, u, &flags);