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;
440 u->recl_subrecord = u->recl;
441 u->bytes_left = u->recl;
445 u->flags.has_recl = 0;
446 u->recl = max_offset;
447 if (compile_options.max_subrecord_length)
449 u->recl_subrecord = compile_options.max_subrecord_length;
453 switch (compile_options.record_marker)
457 case sizeof (GFC_INTEGER_4):
458 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
461 case sizeof (GFC_INTEGER_8):
462 u->recl_subrecord = max_offset - 16;
466 runtime_error ("Illegal value for record marker");
472 /* If the file is direct access, calculate the maximum record number
473 via a division now instead of letting the multiplication overflow
476 if (flags->access == ACCESS_DIRECT)
477 u->maxrec = max_offset / u->recl;
479 if (flags->access == ACCESS_STREAM)
481 u->maxrec = max_offset;
486 memmove (u->file, opp->file, opp->file_len);
487 u->file_len = opp->file_len;
489 /* Curiously, the standard requires that the
490 position specifier be ignored for new files so a newly connected
491 file starts out that the initial point. We still need to figure
492 out if the file is at the end or not. */
496 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
497 free_mem (opp->file);
502 /* Free memory associated with a temporary filename. */
504 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
505 free_mem (opp->file);
514 /* Open a unit which is already open. This involves changing the
515 modes or closing what is there now and opening the new file. */
518 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
520 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
522 edit_modes (opp, u, flags);
526 /* If the file is connected to something else, close it and open a
529 if (!compare_file_filename (u, opp->file, opp->file_len))
531 #if !HAVE_UNLINK_OPEN_FILE
533 if (u->file && u->flags.status == STATUS_SCRATCH)
535 path = (char *) gfc_alloca (u->file_len + 1);
536 unpack_filename (path, u->file, u->file_len);
540 if (sclose (u->s) == FAILURE)
543 generate_error (&opp->common, ERROR_OS,
544 "Error closing file in OPEN statement");
554 #if !HAVE_UNLINK_OPEN_FILE
559 u = new_unit (opp, u, flags);
565 edit_modes (opp, u, flags);
571 extern void st_open (st_parameter_open *opp);
572 export_proto(st_open);
575 st_open (st_parameter_open *opp)
579 GFC_INTEGER_4 cf = opp->common.flags;
582 library_start (&opp->common);
584 /* Decode options. */
586 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
587 find_option (&opp->common, opp->access, opp->access_len,
588 access_opt, "Bad ACCESS parameter in OPEN statement");
590 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
591 find_option (&opp->common, opp->action, opp->action_len,
592 action_opt, "Bad ACTION parameter in OPEN statement");
594 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
595 find_option (&opp->common, opp->blank, opp->blank_len,
596 blank_opt, "Bad BLANK parameter in OPEN statement");
598 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
599 find_option (&opp->common, opp->delim, opp->delim_len,
600 delim_opt, "Bad DELIM parameter in OPEN statement");
602 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
603 find_option (&opp->common, opp->pad, opp->pad_len,
604 pad_opt, "Bad PAD parameter in OPEN statement");
606 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
607 find_option (&opp->common, opp->form, opp->form_len,
608 form_opt, "Bad FORM parameter in OPEN statement");
610 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
611 find_option (&opp->common, opp->position, opp->position_len,
612 position_opt, "Bad POSITION parameter in OPEN statement");
614 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
615 find_option (&opp->common, opp->status, opp->status_len,
616 status_opt, "Bad STATUS parameter in OPEN statement");
618 /* First, we check wether the convert flag has been set via environment
619 variable. This overrides the convert tag in the open statement. */
621 conv = get_unformatted_convert (opp->common.unit);
623 if (conv == CONVERT_NONE)
625 /* Nothing has been set by environment variable, check the convert tag. */
626 if (cf & IOPARM_OPEN_HAS_CONVERT)
627 conv = find_option (&opp->common, opp->convert, opp->convert_len,
629 "Bad CONVERT parameter in OPEN statement");
631 conv = compile_options.convert;
634 /* We use l8_to_l4_offset, which is 0 on little-endian machines
635 and 1 on big-endian machines. */
643 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
647 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
651 internal_error (&opp->common, "Illegal value for CONVERT");
655 flags.convert = conv;
657 if (opp->common.unit < 0)
658 generate_error (&opp->common, ERROR_BAD_OPTION,
659 "Bad unit number in OPEN statement");
661 if (flags.position != POSITION_UNSPECIFIED
662 && flags.access == ACCESS_DIRECT)
663 generate_error (&opp->common, ERROR_BAD_OPTION,
664 "Cannot use POSITION with direct access files");
666 if (flags.access == ACCESS_APPEND)
668 if (flags.position != POSITION_UNSPECIFIED
669 && flags.position != POSITION_APPEND)
670 generate_error (&opp->common, ERROR_BAD_OPTION,
671 "Conflicting ACCESS and POSITION flags in"
674 notify_std (&opp->common, GFC_STD_GNU,
675 "Extension: APPEND as a value for ACCESS in OPEN statement");
676 flags.access = ACCESS_SEQUENTIAL;
677 flags.position = POSITION_APPEND;
680 if (flags.position == POSITION_UNSPECIFIED)
681 flags.position = POSITION_ASIS;
683 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
685 u = find_or_create_unit (opp->common.unit);
689 u = new_unit (opp, u, &flags);
694 already_open (opp, u, &flags);