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. */
35 #include "libgfortran.h"
39 static const st_option access_opt[] = {
40 {"sequential", ACCESS_SEQUENTIAL},
41 {"direct", ACCESS_DIRECT},
42 {"append", ACCESS_APPEND},
43 {"stream", ACCESS_STREAM},
47 static const st_option action_opt[] =
49 { "read", ACTION_READ},
50 { "write", ACTION_WRITE},
51 { "readwrite", ACTION_READWRITE},
55 static const st_option blank_opt[] =
57 { "null", BLANK_NULL},
58 { "zero", BLANK_ZERO},
62 static const st_option delim_opt[] =
64 { "none", DELIM_NONE},
65 { "apostrophe", DELIM_APOSTROPHE},
66 { "quote", DELIM_QUOTE},
70 static const st_option form_opt[] =
72 { "formatted", FORM_FORMATTED},
73 { "unformatted", FORM_UNFORMATTED},
77 static const st_option position_opt[] =
79 { "asis", POSITION_ASIS},
80 { "rewind", POSITION_REWIND},
81 { "append", POSITION_APPEND},
85 static const st_option status_opt[] =
87 { "unknown", STATUS_UNKNOWN},
90 { "replace", STATUS_REPLACE},
91 { "scratch", STATUS_SCRATCH},
95 static const st_option pad_opt[] =
102 static const st_option convert_opt[] =
104 { "native", CONVERT_NATIVE},
105 { "swap", CONVERT_SWAP},
106 { "big_endian", CONVERT_BIG},
107 { "little_endian", CONVERT_LITTLE},
111 /* Given a unit, test to see if the file is positioned at the terminal
112 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
113 This prevents us from changing the state from AFTER_ENDFILE to
117 test_endfile (gfc_unit * u)
119 if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
120 u->endfile = AT_ENDFILE;
124 /* Change the modes of a file, those that are allowed * to be
128 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
130 /* Complain about attempts to change the unchangeable. */
132 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
133 u->flags.status != flags->status)
134 generate_error (&opp->common, ERROR_BAD_OPTION,
135 "Cannot change STATUS parameter in OPEN statement");
137 if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
138 generate_error (&opp->common, ERROR_BAD_OPTION,
139 "Cannot change ACCESS parameter in OPEN statement");
141 if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
142 generate_error (&opp->common, ERROR_BAD_OPTION,
143 "Cannot change FORM parameter in OPEN statement");
145 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
146 && opp->recl_in != u->recl)
147 generate_error (&opp->common, ERROR_BAD_OPTION,
148 "Cannot change RECL parameter in OPEN statement");
150 if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
151 generate_error (&opp->common, ERROR_BAD_OPTION,
152 "Cannot change ACTION parameter in OPEN statement");
154 /* Status must be OLD if present. */
156 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
157 flags->status != STATUS_UNKNOWN)
159 if (flags->status == STATUS_SCRATCH)
160 notify_std (&opp->common, GFC_STD_GNU,
161 "OPEN statement must have a STATUS of OLD or UNKNOWN");
163 generate_error (&opp->common, ERROR_BAD_OPTION,
164 "OPEN statement must have a STATUS of OLD or UNKNOWN");
167 if (u->flags.form == FORM_UNFORMATTED)
169 if (flags->delim != DELIM_UNSPECIFIED)
170 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
171 "DELIM parameter conflicts with UNFORMATTED form in "
174 if (flags->blank != BLANK_UNSPECIFIED)
175 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
176 "BLANK parameter conflicts with UNFORMATTED form in "
179 if (flags->pad != PAD_UNSPECIFIED)
180 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
181 "PAD parameter conflicts with UNFORMATTED form in "
185 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
187 /* Change the changeable: */
188 if (flags->blank != BLANK_UNSPECIFIED)
189 u->flags.blank = flags->blank;
190 if (flags->delim != DELIM_UNSPECIFIED)
191 u->flags.delim = flags->delim;
192 if (flags->pad != PAD_UNSPECIFIED)
193 u->flags.pad = flags->pad;
196 /* Reposition the file if necessary. */
198 switch (flags->position)
200 case POSITION_UNSPECIFIED:
204 case POSITION_REWIND:
205 if (sseek (u->s, 0) == FAILURE)
208 u->current_record = 0;
211 test_endfile (u); /* We might be at the end. */
214 case POSITION_APPEND:
215 if (sseek (u->s, file_length (u->s)) == FAILURE)
218 if (flags->access != ACCESS_STREAM)
219 u->current_record = 0;
221 u->endfile = AT_ENDFILE; /* We are at the end. */
225 generate_error (&opp->common, ERROR_OS, NULL);
233 /* Open an unused unit. */
236 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
240 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
242 /* Change unspecifieds to defaults. Leave (flags->action ==
243 ACTION_UNSPECIFIED) alone so open_external() can set it based on
244 what type of open actually works. */
246 if (flags->access == ACCESS_UNSPECIFIED)
247 flags->access = ACCESS_SEQUENTIAL;
249 if (flags->form == FORM_UNSPECIFIED)
250 flags->form = (flags->access == ACCESS_SEQUENTIAL)
251 ? FORM_FORMATTED : FORM_UNFORMATTED;
254 if (flags->delim == DELIM_UNSPECIFIED)
255 flags->delim = DELIM_NONE;
258 if (flags->form == FORM_UNFORMATTED)
260 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
261 "DELIM parameter conflicts with UNFORMATTED form in "
267 if (flags->blank == BLANK_UNSPECIFIED)
268 flags->blank = BLANK_NULL;
271 if (flags->form == FORM_UNFORMATTED)
273 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
274 "BLANK parameter conflicts with UNFORMATTED form in "
280 if (flags->pad == PAD_UNSPECIFIED)
281 flags->pad = PAD_YES;
284 if (flags->form == FORM_UNFORMATTED)
286 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
287 "PAD parameter conflicts with UNFORMATTED form in "
293 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
295 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
296 "ACCESS parameter conflicts with SEQUENTIAL access in "
301 if (flags->position == POSITION_UNSPECIFIED)
302 flags->position = POSITION_ASIS;
305 if (flags->status == STATUS_UNSPECIFIED)
306 flags->status = STATUS_UNKNOWN;
310 if (flags->access == ACCESS_DIRECT
311 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
313 generate_error (&opp->common, ERROR_MISSING_OPTION,
314 "Missing RECL parameter in OPEN statement");
318 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
320 generate_error (&opp->common, ERROR_BAD_OPTION,
321 "RECL parameter is non-positive in OPEN statement");
325 switch (flags->status)
328 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
334 generate_error (&opp->common, ERROR_BAD_OPTION,
335 "FILE parameter must not be present in OPEN statement");
342 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
346 opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
350 internal_error (&opp->common, "new_unit(): Bad status");
353 /* Make sure the file isn't already open someplace else.
354 Do not error if opening file preconnected to stdin, stdout, stderr. */
357 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
358 u2 = find_file (opp->file, opp->file_len);
360 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
361 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
362 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
365 generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
374 s = open_external (opp, flags);
377 generate_error (&opp->common, ERROR_OS, NULL);
381 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
382 flags->status = STATUS_OLD;
384 /* Create the unit structure. */
386 u->file = get_mem (opp->file_len);
387 if (u->unit_number != opp->common.unit)
388 internal_error (&opp->common, "Unit number changed");
392 u->endfile = NO_ENDFILE;
394 u->current_record = 0;
399 if (flags->position == POSITION_APPEND)
401 if (sseek (u->s, file_length (u->s)) == FAILURE)
402 generate_error (&opp->common, ERROR_OS, NULL);
403 u->endfile = AT_ENDFILE;
406 /* Unspecified recl ends up with a processor dependent value. */
408 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
409 u->recl = opp->recl_in;
412 switch (compile_options.record_marker)
415 u->recl = max_offset;
418 case sizeof (GFC_INTEGER_4):
419 u->recl = GFC_INTEGER_4_HUGE;
422 case sizeof (GFC_INTEGER_8):
423 u->recl = max_offset;
427 runtime_error ("Illegal value for record marker");
432 /* If the file is direct access, calculate the maximum record number
433 via a division now instead of letting the multiplication overflow
436 if (flags->access == ACCESS_DIRECT)
437 u->maxrec = max_offset / u->recl;
439 if (flags->access == ACCESS_STREAM)
441 u->maxrec = max_offset;
446 memmove (u->file, opp->file, opp->file_len);
447 u->file_len = opp->file_len;
449 /* Curiously, the standard requires that the
450 position specifier be ignored for new files so a newly connected
451 file starts out that the initial point. We still need to figure
452 out if the file is at the end or not. */
456 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
457 free_mem (opp->file);
462 /* Free memory associated with a temporary filename. */
464 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
465 free_mem (opp->file);
474 /* Open a unit which is already open. This involves changing the
475 modes or closing what is there now and opening the new file. */
478 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
480 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
482 edit_modes (opp, u, flags);
486 /* If the file is connected to something else, close it and open a
489 if (!compare_file_filename (u, opp->file, opp->file_len))
491 #if !HAVE_UNLINK_OPEN_FILE
493 if (u->file && u->flags.status == STATUS_SCRATCH)
495 path = (char *) gfc_alloca (u->file_len + 1);
496 unpack_filename (path, u->file, u->file_len);
500 if (sclose (u->s) == FAILURE)
503 generate_error (&opp->common, ERROR_OS,
504 "Error closing file in OPEN statement");
514 #if !HAVE_UNLINK_OPEN_FILE
519 u = new_unit (opp, u, flags);
525 edit_modes (opp, u, flags);
531 extern void st_open (st_parameter_open *opp);
532 export_proto(st_open);
535 st_open (st_parameter_open *opp)
539 GFC_INTEGER_4 cf = opp->common.flags;
542 library_start (&opp->common);
544 /* Decode options. */
546 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
547 find_option (&opp->common, opp->access, opp->access_len,
548 access_opt, "Bad ACCESS parameter in OPEN statement");
550 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
551 find_option (&opp->common, opp->action, opp->action_len,
552 action_opt, "Bad ACTION parameter in OPEN statement");
554 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
555 find_option (&opp->common, opp->blank, opp->blank_len,
556 blank_opt, "Bad BLANK parameter in OPEN statement");
558 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
559 find_option (&opp->common, opp->delim, opp->delim_len,
560 delim_opt, "Bad DELIM parameter in OPEN statement");
562 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
563 find_option (&opp->common, opp->pad, opp->pad_len,
564 pad_opt, "Bad PAD parameter in OPEN statement");
566 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
567 find_option (&opp->common, opp->form, opp->form_len,
568 form_opt, "Bad FORM parameter in OPEN statement");
570 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
571 find_option (&opp->common, opp->position, opp->position_len,
572 position_opt, "Bad POSITION parameter in OPEN statement");
574 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
575 find_option (&opp->common, opp->status, opp->status_len,
576 status_opt, "Bad STATUS parameter in OPEN statement");
578 /* First, we check wether the convert flag has been set via environment
579 variable. This overrides the convert tag in the open statement. */
581 conv = get_unformatted_convert (opp->common.unit);
583 if (conv == CONVERT_NONE)
585 /* Nothing has been set by environment variable, check the convert tag. */
586 if (cf & IOPARM_OPEN_HAS_CONVERT)
587 conv = find_option (&opp->common, opp->convert, opp->convert_len,
589 "Bad CONVERT parameter in OPEN statement");
591 conv = compile_options.convert;
594 /* We use l8_to_l4_offset, which is 0 on little-endian machines
595 and 1 on big-endian machines. */
603 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
607 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
611 internal_error (&opp->common, "Illegal value for CONVERT");
615 flags.convert = conv;
617 if (opp->common.unit < 0)
618 generate_error (&opp->common, ERROR_BAD_OPTION,
619 "Bad unit number in OPEN statement");
621 if (flags.position != POSITION_UNSPECIFIED
622 && flags.access == ACCESS_DIRECT)
623 generate_error (&opp->common, ERROR_BAD_OPTION,
624 "Cannot use POSITION with direct access files");
626 if (flags.access == ACCESS_APPEND)
628 if (flags.position != POSITION_UNSPECIFIED
629 && flags.position != POSITION_APPEND)
630 generate_error (&opp->common, ERROR_BAD_OPTION,
631 "Conflicting ACCESS and POSITION flags in"
634 notify_std (&opp->common, GFC_STD_GNU,
635 "Extension: APPEND as a value for ACCESS in OPEN statement");
636 flags.access = ACCESS_SEQUENTIAL;
637 flags.position = POSITION_APPEND;
640 if (flags.position == POSITION_UNSPECIFIED)
641 flags.position = POSITION_ASIS;
643 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
645 u = find_or_create_unit (opp->common.unit);
649 u = new_unit (opp, u, &flags);
654 already_open (opp, u, &flags);