1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007
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. */
37 static const st_option access_opt
[] = {
38 {"sequential", ACCESS_SEQUENTIAL
},
39 {"direct", ACCESS_DIRECT
},
40 {"append", ACCESS_APPEND
},
41 {"stream", ACCESS_STREAM
},
45 static const st_option action_opt
[] =
47 { "read", ACTION_READ
},
48 { "write", ACTION_WRITE
},
49 { "readwrite", ACTION_READWRITE
},
53 static const st_option blank_opt
[] =
55 { "null", BLANK_NULL
},
56 { "zero", BLANK_ZERO
},
60 static const st_option delim_opt
[] =
62 { "none", DELIM_NONE
},
63 { "apostrophe", DELIM_APOSTROPHE
},
64 { "quote", DELIM_QUOTE
},
68 static const st_option form_opt
[] =
70 { "formatted", FORM_FORMATTED
},
71 { "unformatted", FORM_UNFORMATTED
},
75 static const st_option position_opt
[] =
77 { "asis", POSITION_ASIS
},
78 { "rewind", POSITION_REWIND
},
79 { "append", POSITION_APPEND
},
83 static const st_option status_opt
[] =
85 { "unknown", STATUS_UNKNOWN
},
88 { "replace", STATUS_REPLACE
},
89 { "scratch", STATUS_SCRATCH
},
93 static const st_option pad_opt
[] =
100 static const st_option convert_opt
[] =
102 { "native", GFC_CONVERT_NATIVE
},
103 { "swap", GFC_CONVERT_SWAP
},
104 { "big_endian", GFC_CONVERT_BIG
},
105 { "little_endian", GFC_CONVERT_LITTLE
},
110 /* Given a unit, test to see if the file is positioned at the terminal
111 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
112 This prevents us from changing the state from AFTER_ENDFILE to
116 test_endfile (gfc_unit
* u
)
118 if (u
->endfile
== NO_ENDFILE
&& file_length (u
->s
) == file_position (u
->s
))
119 u
->endfile
= AT_ENDFILE
;
123 /* Change the modes of a file, those that are allowed * to be
127 edit_modes (st_parameter_open
*opp
, gfc_unit
* u
, unit_flags
* flags
)
129 /* Complain about attempts to change the unchangeable. */
131 if (flags
->status
!= STATUS_UNSPECIFIED
&& flags
->status
!= STATUS_OLD
&&
132 u
->flags
.status
!= flags
->status
)
133 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
134 "Cannot change STATUS parameter in OPEN statement");
136 if (flags
->access
!= ACCESS_UNSPECIFIED
&& u
->flags
.access
!= flags
->access
)
137 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
138 "Cannot change ACCESS parameter in OPEN statement");
140 if (flags
->form
!= FORM_UNSPECIFIED
&& u
->flags
.form
!= flags
->form
)
141 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
142 "Cannot change FORM parameter in OPEN statement");
144 if ((opp
->common
.flags
& IOPARM_OPEN_HAS_RECL_IN
)
145 && opp
->recl_in
!= u
->recl
)
146 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
147 "Cannot change RECL parameter in OPEN statement");
149 if (flags
->action
!= ACTION_UNSPECIFIED
&& u
->flags
.action
!= flags
->action
)
150 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
151 "Cannot change ACTION parameter in OPEN statement");
153 /* Status must be OLD if present. */
155 if (flags
->status
!= STATUS_UNSPECIFIED
&& flags
->status
!= STATUS_OLD
&&
156 flags
->status
!= STATUS_UNKNOWN
)
158 if (flags
->status
== STATUS_SCRATCH
)
159 notify_std (&opp
->common
, GFC_STD_GNU
,
160 "OPEN statement must have a STATUS of OLD or UNKNOWN");
162 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
163 "OPEN statement must have a STATUS of OLD or UNKNOWN");
166 if (u
->flags
.form
== FORM_UNFORMATTED
)
168 if (flags
->delim
!= DELIM_UNSPECIFIED
)
169 generate_error (&opp
->common
, LIBERROR_OPTION_CONFLICT
,
170 "DELIM parameter conflicts with UNFORMATTED form in "
173 if (flags
->blank
!= BLANK_UNSPECIFIED
)
174 generate_error (&opp
->common
, LIBERROR_OPTION_CONFLICT
,
175 "BLANK parameter conflicts with UNFORMATTED form in "
178 if (flags
->pad
!= PAD_UNSPECIFIED
)
179 generate_error (&opp
->common
, LIBERROR_OPTION_CONFLICT
,
180 "PAD parameter conflicts with UNFORMATTED form in "
184 if ((opp
->common
.flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_OK
)
186 /* Change the changeable: */
187 if (flags
->blank
!= BLANK_UNSPECIFIED
)
188 u
->flags
.blank
= flags
->blank
;
189 if (flags
->delim
!= DELIM_UNSPECIFIED
)
190 u
->flags
.delim
= flags
->delim
;
191 if (flags
->pad
!= PAD_UNSPECIFIED
)
192 u
->flags
.pad
= flags
->pad
;
195 /* Reposition the file if necessary. */
197 switch (flags
->position
)
199 case POSITION_UNSPECIFIED
:
203 case POSITION_REWIND
:
204 if (sseek (u
->s
, 0) == FAILURE
)
207 u
->current_record
= 0;
213 case POSITION_APPEND
:
214 if (sseek (u
->s
, file_length (u
->s
)) == FAILURE
)
217 if (flags
->access
!= ACCESS_STREAM
)
218 u
->current_record
= 0;
220 u
->endfile
= AT_ENDFILE
; /* We are at the end. */
224 generate_error (&opp
->common
, LIBERROR_OS
, NULL
);
232 /* Open an unused unit. */
235 new_unit (st_parameter_open
*opp
, gfc_unit
*u
, unit_flags
* flags
)
239 char tmpname
[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
241 /* Change unspecifieds to defaults. Leave (flags->action ==
242 ACTION_UNSPECIFIED) alone so open_external() can set it based on
243 what type of open actually works. */
245 if (flags
->access
== ACCESS_UNSPECIFIED
)
246 flags
->access
= ACCESS_SEQUENTIAL
;
248 if (flags
->form
== FORM_UNSPECIFIED
)
249 flags
->form
= (flags
->access
== ACCESS_SEQUENTIAL
)
250 ? FORM_FORMATTED
: FORM_UNFORMATTED
;
253 if (flags
->delim
== DELIM_UNSPECIFIED
)
254 flags
->delim
= DELIM_NONE
;
257 if (flags
->form
== FORM_UNFORMATTED
)
259 generate_error (&opp
->common
, LIBERROR_OPTION_CONFLICT
,
260 "DELIM parameter conflicts with UNFORMATTED form in "
266 if (flags
->blank
== BLANK_UNSPECIFIED
)
267 flags
->blank
= BLANK_NULL
;
270 if (flags
->form
== FORM_UNFORMATTED
)
272 generate_error (&opp
->common
, LIBERROR_OPTION_CONFLICT
,
273 "BLANK parameter conflicts with UNFORMATTED form in "
279 if (flags
->pad
== PAD_UNSPECIFIED
)
280 flags
->pad
= PAD_YES
;
283 if (flags
->form
== FORM_UNFORMATTED
)
285 generate_error (&opp
->common
, LIBERROR_OPTION_CONFLICT
,
286 "PAD parameter conflicts with UNFORMATTED form in "
292 if (flags
->position
!= POSITION_ASIS
&& flags
->access
== ACCESS_DIRECT
)
294 generate_error (&opp
->common
, LIBERROR_OPTION_CONFLICT
,
295 "ACCESS parameter conflicts with SEQUENTIAL access in "
300 if (flags
->position
== POSITION_UNSPECIFIED
)
301 flags
->position
= POSITION_ASIS
;
304 if (flags
->status
== STATUS_UNSPECIFIED
)
305 flags
->status
= STATUS_UNKNOWN
;
309 if (flags
->access
== ACCESS_DIRECT
310 && (opp
->common
.flags
& IOPARM_OPEN_HAS_RECL_IN
) == 0)
312 generate_error (&opp
->common
, LIBERROR_MISSING_OPTION
,
313 "Missing RECL parameter in OPEN statement");
317 if ((opp
->common
.flags
& IOPARM_OPEN_HAS_RECL_IN
) && opp
->recl_in
<= 0)
319 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
320 "RECL parameter is non-positive in OPEN statement");
324 switch (flags
->status
)
327 if ((opp
->common
.flags
& IOPARM_OPEN_HAS_FILE
) == 0)
333 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
334 "FILE parameter must not be present in OPEN statement");
341 if ((opp
->common
.flags
& IOPARM_OPEN_HAS_FILE
))
346 opp
->file_len
= snprintf(opp
->file
, sizeof (tmpname
), "fort.%d",
347 (int) opp
->common
.unit
);
349 opp
->file_len
= sprintf(opp
->file
, "fort.%d", (int) opp
->common
.unit
);
354 internal_error (&opp
->common
, "new_unit(): Bad status");
357 /* Make sure the file isn't already open someplace else.
358 Do not error if opening file preconnected to stdin, stdout, stderr. */
361 if ((opp
->common
.flags
& IOPARM_OPEN_HAS_FILE
) != 0)
362 u2
= find_file (opp
->file
, opp
->file_len
);
364 && (options
.stdin_unit
< 0 || u2
->unit_number
!= options
.stdin_unit
)
365 && (options
.stdout_unit
< 0 || u2
->unit_number
!= options
.stdout_unit
)
366 && (options
.stderr_unit
< 0 || u2
->unit_number
!= options
.stderr_unit
))
369 generate_error (&opp
->common
, LIBERROR_ALREADY_OPEN
, NULL
);
378 s
= open_external (opp
, flags
);
382 path
= (char *) gfc_alloca (opp
->file_len
+ 1);
383 msg
= (char *) gfc_alloca (opp
->file_len
+ 51);
384 unpack_filename (path
, opp
->file
, opp
->file_len
);
389 sprintf (msg
, "File '%s' does not exist", path
);
393 sprintf (msg
, "File '%s' already exists", path
);
397 sprintf (msg
, "Permission denied trying to open file '%s'", path
);
401 sprintf (msg
, "'%s' is a directory", path
);
408 generate_error (&opp
->common
, LIBERROR_OS
, msg
);
412 if (flags
->status
== STATUS_NEW
|| flags
->status
== STATUS_REPLACE
)
413 flags
->status
= STATUS_OLD
;
415 /* Create the unit structure. */
417 u
->file
= get_mem (opp
->file_len
);
418 if (u
->unit_number
!= opp
->common
.unit
)
419 internal_error (&opp
->common
, "Unit number changed");
423 u
->endfile
= NO_ENDFILE
;
425 u
->current_record
= 0;
431 if (flags
->position
== POSITION_APPEND
)
433 if (sseek (u
->s
, file_length (u
->s
)) == FAILURE
)
434 generate_error (&opp
->common
, LIBERROR_OS
, NULL
);
435 u
->endfile
= AT_ENDFILE
;
438 /* Unspecified recl ends up with a processor dependent value. */
440 if ((opp
->common
.flags
& IOPARM_OPEN_HAS_RECL_IN
))
442 u
->flags
.has_recl
= 1;
443 u
->recl
= opp
->recl_in
;
444 u
->recl_subrecord
= u
->recl
;
445 u
->bytes_left
= u
->recl
;
449 u
->flags
.has_recl
= 0;
450 u
->recl
= max_offset
;
451 if (compile_options
.max_subrecord_length
)
453 u
->recl_subrecord
= compile_options
.max_subrecord_length
;
457 switch (compile_options
.record_marker
)
461 case sizeof (GFC_INTEGER_4
):
462 u
->recl_subrecord
= GFC_MAX_SUBRECORD_LENGTH
;
465 case sizeof (GFC_INTEGER_8
):
466 u
->recl_subrecord
= max_offset
- 16;
470 runtime_error ("Illegal value for record marker");
476 /* If the file is direct access, calculate the maximum record number
477 via a division now instead of letting the multiplication overflow
480 if (flags
->access
== ACCESS_DIRECT
)
481 u
->maxrec
= max_offset
/ u
->recl
;
483 if (flags
->access
== ACCESS_STREAM
)
485 u
->maxrec
= max_offset
;
490 memmove (u
->file
, opp
->file
, opp
->file_len
);
491 u
->file_len
= opp
->file_len
;
493 /* Curiously, the standard requires that the
494 position specifier be ignored for new files so a newly connected
495 file starts out at the initial point. We still need to figure
496 out if the file is at the end or not. */
500 if (flags
->status
== STATUS_SCRATCH
&& opp
->file
!= NULL
)
501 free_mem (opp
->file
);
506 /* Free memory associated with a temporary filename. */
508 if (flags
->status
== STATUS_SCRATCH
&& opp
->file
!= NULL
)
509 free_mem (opp
->file
);
518 /* Open a unit which is already open. This involves changing the
519 modes or closing what is there now and opening the new file. */
522 already_open (st_parameter_open
*opp
, gfc_unit
* u
, unit_flags
* flags
)
524 if ((opp
->common
.flags
& IOPARM_OPEN_HAS_FILE
) == 0)
526 edit_modes (opp
, u
, flags
);
530 /* If the file is connected to something else, close it and open a
533 if (!compare_file_filename (u
, opp
->file
, opp
->file_len
))
535 #if !HAVE_UNLINK_OPEN_FILE
537 if (u
->file
&& u
->flags
.status
== STATUS_SCRATCH
)
539 path
= (char *) gfc_alloca (u
->file_len
+ 1);
540 unpack_filename (path
, u
->file
, u
->file_len
);
544 if (sclose (u
->s
) == FAILURE
)
547 generate_error (&opp
->common
, LIBERROR_OS
,
548 "Error closing file in OPEN statement");
558 #if !HAVE_UNLINK_OPEN_FILE
563 u
= new_unit (opp
, u
, flags
);
569 edit_modes (opp
, u
, flags
);
575 extern void st_open (st_parameter_open
*opp
);
576 export_proto(st_open
);
579 st_open (st_parameter_open
*opp
)
583 GFC_INTEGER_4 cf
= opp
->common
.flags
;
586 library_start (&opp
->common
);
588 /* Decode options. */
590 flags
.access
= !(cf
& IOPARM_OPEN_HAS_ACCESS
) ? ACCESS_UNSPECIFIED
:
591 find_option (&opp
->common
, opp
->access
, opp
->access_len
,
592 access_opt
, "Bad ACCESS parameter in OPEN statement");
594 flags
.action
= !(cf
& IOPARM_OPEN_HAS_ACTION
) ? ACTION_UNSPECIFIED
:
595 find_option (&opp
->common
, opp
->action
, opp
->action_len
,
596 action_opt
, "Bad ACTION parameter in OPEN statement");
598 flags
.blank
= !(cf
& IOPARM_OPEN_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
599 find_option (&opp
->common
, opp
->blank
, opp
->blank_len
,
600 blank_opt
, "Bad BLANK parameter in OPEN statement");
602 flags
.delim
= !(cf
& IOPARM_OPEN_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
603 find_option (&opp
->common
, opp
->delim
, opp
->delim_len
,
604 delim_opt
, "Bad DELIM parameter in OPEN statement");
606 flags
.pad
= !(cf
& IOPARM_OPEN_HAS_PAD
) ? PAD_UNSPECIFIED
:
607 find_option (&opp
->common
, opp
->pad
, opp
->pad_len
,
608 pad_opt
, "Bad PAD parameter in OPEN statement");
610 flags
.form
= !(cf
& IOPARM_OPEN_HAS_FORM
) ? FORM_UNSPECIFIED
:
611 find_option (&opp
->common
, opp
->form
, opp
->form_len
,
612 form_opt
, "Bad FORM parameter in OPEN statement");
614 flags
.position
= !(cf
& IOPARM_OPEN_HAS_POSITION
) ? POSITION_UNSPECIFIED
:
615 find_option (&opp
->common
, opp
->position
, opp
->position_len
,
616 position_opt
, "Bad POSITION parameter in OPEN statement");
618 flags
.status
= !(cf
& IOPARM_OPEN_HAS_STATUS
) ? STATUS_UNSPECIFIED
:
619 find_option (&opp
->common
, opp
->status
, opp
->status_len
,
620 status_opt
, "Bad STATUS parameter in OPEN statement");
622 /* First, we check wether the convert flag has been set via environment
623 variable. This overrides the convert tag in the open statement. */
625 conv
= get_unformatted_convert (opp
->common
.unit
);
627 if (conv
== GFC_CONVERT_NONE
)
629 /* Nothing has been set by environment variable, check the convert tag. */
630 if (cf
& IOPARM_OPEN_HAS_CONVERT
)
631 conv
= find_option (&opp
->common
, opp
->convert
, opp
->convert_len
,
633 "Bad CONVERT parameter in OPEN statement");
635 conv
= compile_options
.convert
;
638 /* We use l8_to_l4_offset, which is 0 on little-endian machines
639 and 1 on big-endian machines. */
642 case GFC_CONVERT_NATIVE
:
643 case GFC_CONVERT_SWAP
:
646 case GFC_CONVERT_BIG
:
647 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
650 case GFC_CONVERT_LITTLE
:
651 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
655 internal_error (&opp
->common
, "Illegal value for CONVERT");
659 flags
.convert
= conv
;
661 if (opp
->common
.unit
< 0)
662 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
663 "Bad unit number in OPEN statement");
665 if (flags
.position
!= POSITION_UNSPECIFIED
666 && flags
.access
== ACCESS_DIRECT
)
667 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
668 "Cannot use POSITION with direct access files");
670 if (flags
.access
== ACCESS_APPEND
)
672 if (flags
.position
!= POSITION_UNSPECIFIED
673 && flags
.position
!= POSITION_APPEND
)
674 generate_error (&opp
->common
, LIBERROR_BAD_OPTION
,
675 "Conflicting ACCESS and POSITION flags in"
678 notify_std (&opp
->common
, GFC_STD_GNU
,
679 "Extension: APPEND as a value for ACCESS in OPEN statement");
680 flags
.access
= ACCESS_SEQUENTIAL
;
681 flags
.position
= POSITION_APPEND
;
684 if (flags
.position
== POSITION_UNSPECIFIED
)
685 flags
.position
= POSITION_ASIS
;
687 if ((opp
->common
.flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_OK
)
689 u
= find_or_create_unit (opp
->common
.unit
);
693 u
= new_unit (opp
, u
, &flags
);
698 already_open (opp
, u
, &flags
);