1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with Libgfortran; see the file COPYING. If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
25 #include "libgfortran.h"
29 static st_option access_opt
[] = {
30 {"sequential", ACCESS_SEQUENTIAL
},
31 {"direct", ACCESS_DIRECT
},
39 "write", ACTION_WRITE
}
42 "readwrite", ACTION_READWRITE
}
66 "apostrophe", DELIM_APOSTROPHE
}
78 "formatted", FORM_FORMATTED
}
81 "unformatted", FORM_UNFORMATTED
}
90 "asis", POSITION_ASIS
}
93 "rewind", POSITION_REWIND
}
96 "append", POSITION_APPEND
}
105 "unknown", STATUS_UNKNOWN
}
114 "replace", STATUS_REPLACE
}
117 "scratch", STATUS_SCRATCH
}
136 /* Given a unit, test to see if the file is positioned at the terminal
137 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
138 This prevents us from changing the state from AFTER_ENDFILE to
142 test_endfile (gfc_unit
* u
)
145 if (u
->endfile
== NO_ENDFILE
&& file_length (u
->s
) == file_position (u
->s
))
146 u
->endfile
= AT_ENDFILE
;
150 /* Change the modes of a file, those that are allowed * to be
154 edit_modes (gfc_unit
* u
, unit_flags
* flags
)
157 /* Complain about attempts to change the unchangeable. */
159 if (flags
->status
!= STATUS_UNSPECIFIED
&&
160 u
->flags
.status
!= flags
->position
)
161 generate_error (ERROR_BAD_OPTION
,
162 "Cannot change STATUS parameter in OPEN statement");
164 if (flags
->access
!= ACCESS_UNSPECIFIED
&& u
->flags
.access
!= flags
->access
)
165 generate_error (ERROR_BAD_OPTION
,
166 "Cannot change ACCESS parameter in OPEN statement");
168 if (flags
->form
!= FORM_UNSPECIFIED
&& u
->flags
.form
!= flags
->form
)
169 generate_error (ERROR_BAD_OPTION
,
170 "Cannot change FORM parameter in OPEN statement");
172 if (ioparm
.recl_in
!= 0 && ioparm
.recl_in
!= u
->recl
)
173 generate_error (ERROR_BAD_OPTION
,
174 "Cannot change RECL parameter in OPEN statement");
176 if (flags
->action
!= ACTION_UNSPECIFIED
&& u
->flags
.access
!= flags
->access
)
177 generate_error (ERROR_BAD_OPTION
,
178 "Cannot change ACTION parameter in OPEN statement");
180 /* Status must be OLD if present. */
182 if (flags
->status
!= STATUS_UNSPECIFIED
&& flags
->status
!= STATUS_OLD
)
183 generate_error (ERROR_BAD_OPTION
,
184 "OPEN statement must have a STATUS of OLD");
186 if (u
->flags
.form
== FORM_UNFORMATTED
)
188 if (flags
->delim
!= DELIM_UNSPECIFIED
)
189 generate_error (ERROR_OPTION_CONFLICT
,
190 "DELIM parameter conflicts with UNFORMATTED form in "
193 if (flags
->blank
!= BLANK_UNSPECIFIED
)
194 generate_error (ERROR_OPTION_CONFLICT
,
195 "BLANK parameter conflicts with UNFORMATTED form in "
198 if (flags
->pad
!= PAD_UNSPECIFIED
)
199 generate_error (ERROR_OPTION_CONFLICT
,
200 "PAD paramter conflicts with UNFORMATTED form in "
204 if (ioparm
.library_return
== LIBRARY_OK
)
206 /* Change the changeable: */
207 if (flags
->blank
!= BLANK_UNSPECIFIED
)
208 u
->flags
.blank
= flags
->blank
;
209 if (flags
->delim
!= DELIM_UNSPECIFIED
)
210 u
->flags
.delim
= flags
->delim
;
211 if (flags
->pad
!= PAD_UNSPECIFIED
)
212 u
->flags
.pad
= flags
->pad
;
215 /* Reposition the file if necessary. */
217 switch (flags
->position
)
219 case POSITION_UNSPECIFIED
:
223 case POSITION_REWIND
:
224 if (sseek (u
->s
, 0) == FAILURE
)
227 u
->current_record
= 0;
230 test_endfile (u
); /* We might be at the end. */
233 case POSITION_APPEND
:
234 if (sseek (u
->s
, file_length (u
->s
)) == FAILURE
)
237 u
->current_record
= 0;
238 u
->endfile
= AT_ENDFILE
; /* We are at the end. */
242 generate_error (ERROR_OS
, NULL
);
248 /* Open an unused unit. */
251 new_unit (unit_flags
* flags
)
255 char tmpname
[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
257 /* Change unspecifieds to defaults. */
259 if (flags
->access
== ACCESS_UNSPECIFIED
)
260 flags
->access
= ACCESS_SEQUENTIAL
;
262 if (flags
->action
== ACTION_UNSPECIFIED
)
263 flags
->action
= ACTION_READWRITE
; /* Processor dependent. */
265 if (flags
->form
== FORM_UNSPECIFIED
)
266 flags
->form
= (flags
->access
== ACCESS_SEQUENTIAL
)
267 ? FORM_FORMATTED
: FORM_UNFORMATTED
;
270 if (flags
->delim
== DELIM_UNSPECIFIED
)
271 flags
->delim
= DELIM_NONE
;
274 if (flags
->form
== FORM_UNFORMATTED
)
276 generate_error (ERROR_OPTION_CONFLICT
,
277 "DELIM parameter conflicts with UNFORMATTED form in "
283 if (flags
->blank
== BLANK_UNSPECIFIED
)
284 flags
->blank
= BLANK_NULL
;
287 if (flags
->form
== FORM_UNFORMATTED
)
289 generate_error (ERROR_OPTION_CONFLICT
,
290 "BLANK parameter conflicts with UNFORMATTED form in "
296 if (flags
->pad
== PAD_UNSPECIFIED
)
297 flags
->pad
= PAD_YES
;
300 if (flags
->form
== FORM_UNFORMATTED
)
302 generate_error (ERROR_OPTION_CONFLICT
,
303 "PAD paramter conflicts with UNFORMATTED form in "
309 if (flags
->position
!= POSITION_ASIS
&& flags
->access
== ACCESS_DIRECT
)
311 generate_error (ERROR_OPTION_CONFLICT
,
312 "ACCESS parameter conflicts with SEQUENTIAL access in "
317 if (flags
->position
== POSITION_UNSPECIFIED
)
318 flags
->position
= POSITION_ASIS
;
321 if (flags
->status
== STATUS_UNSPECIFIED
)
322 flags
->status
= STATUS_UNKNOWN
;
326 if (flags
->access
== ACCESS_DIRECT
&& ioparm
.recl_in
== 0)
328 generate_error (ERROR_MISSING_OPTION
,
329 "Missing RECL parameter in OPEN statement");
333 if (ioparm
.recl_in
!= 0 && ioparm
.recl_in
<= 0)
335 generate_error (ERROR_BAD_OPTION
,
336 "RECL parameter is non-positive in OPEN statement");
340 switch (flags
->status
)
343 if (ioparm
.file
== NULL
)
346 generate_error (ERROR_BAD_OPTION
,
347 "FILE parameter must not be present in OPEN statement");
354 if (ioparm
.file
!= NULL
)
357 ioparm
.file
= tmpname
;
358 ioparm
.file_len
= sprintf(ioparm
.file
, "fort.%d", ioparm
.unit
);
362 internal_error ("new_unit(): Bad status");
365 /* Make sure the file isn't already open someplace else. */
367 if (find_file () != NULL
)
369 generate_error (ERROR_ALREADY_OPEN
, NULL
);
375 s
= open_external (flags
->action
, flags
->status
);
378 generate_error (ERROR_OS
, NULL
);
382 if (flags
->status
== STATUS_NEW
|| flags
->status
== STATUS_REPLACE
)
383 flags
->status
= STATUS_OLD
;
385 /* Create the unit structure. */
387 u
= get_mem (sizeof (gfc_unit
) + ioparm
.file_len
);
389 u
->unit_number
= ioparm
.unit
;
393 /* Unspecified recl ends up with a processor dependent value. */
395 u
->recl
= (ioparm
.recl_in
!= 0) ? ioparm
.recl_in
: DEFAULT_RECL
;
397 u
->current_record
= 0;
399 /* If the file is direct access, calculate the maximum record number
400 via a division now instead of letting the multiplication overflow
403 if (flags
->access
== ACCESS_DIRECT
)
404 u
->maxrec
= g
.max_offset
/ u
->recl
;
406 memmove (u
->file
, ioparm
.file
, ioparm
.file_len
);
407 u
->file_len
= ioparm
.file_len
;
411 /* The file is now connected. Errors after this point leave the
412 file connected. Curiously, the standard requires that the
413 position specifier be ignored for new files so a newly connected
414 file starts out that the initial point. We still need to figure
415 out if the file is at the end or not. */
421 /* Free memory associated with a temporary filename. */
423 if (flags
->status
== STATUS_SCRATCH
)
424 free_mem (ioparm
.file
);
428 /* Open a unit which is already open. This involves changing the
429 modes or closing what is there now and opening the new file. */
432 already_open (gfc_unit
* u
, unit_flags
* flags
)
435 if (ioparm
.file
== NULL
)
437 edit_modes (u
, flags
);
441 /* If the file is connected to something else, close it and open a
444 if (!compare_file_filename (u
->s
, ioparm
.file
, ioparm
.file_len
))
448 generate_error (ERROR_OS
, "Error closing file in OPEN statement");
456 edit_modes (u
, flags
);
470 /* Decode options. */
472 flags
.access
= (ioparm
.access
== NULL
) ? ACCESS_UNSPECIFIED
:
473 find_option (ioparm
.access
, ioparm
.access_len
, access_opt
,
474 "Bad ACCESS parameter in OPEN statement");
476 flags
.action
= (ioparm
.action
== NULL
) ? ACTION_UNSPECIFIED
:
477 find_option (ioparm
.action
, ioparm
.action_len
, action_opt
,
478 "Bad ACTION parameter in OPEN statement");
480 flags
.blank
= (ioparm
.blank
== NULL
) ? BLANK_UNSPECIFIED
:
481 find_option (ioparm
.blank
, ioparm
.blank_len
, blank_opt
,
482 "Bad BLANK parameter in OPEN statement");
484 flags
.delim
= (ioparm
.delim
== NULL
) ? DELIM_UNSPECIFIED
:
485 find_option (ioparm
.delim
, ioparm
.delim_len
, delim_opt
,
486 "Bad DELIM parameter in OPEN statement");
488 flags
.pad
= (ioparm
.pad
== NULL
) ? PAD_UNSPECIFIED
:
489 find_option (ioparm
.pad
, ioparm
.pad_len
, pad_opt
,
490 "Bad PAD parameter in OPEN statement");
492 flags
.form
= (ioparm
.form
== NULL
) ? FORM_UNSPECIFIED
:
493 find_option (ioparm
.form
, ioparm
.form_len
, form_opt
,
494 "Bad FORM parameter in OPEN statement");
496 flags
.position
= (ioparm
.position
== NULL
) ? POSITION_UNSPECIFIED
:
497 find_option (ioparm
.position
, ioparm
.position_len
, position_opt
,
498 "Bad POSITION parameter in OPEN statement");
500 flags
.status
= (ioparm
.status
== NULL
) ? STATUS_UNSPECIFIED
:
501 find_option (ioparm
.status
, ioparm
.status_len
, status_opt
,
502 "Bad STATUS parameter in OPEN statement");
505 generate_error (ERROR_BAD_OPTION
, "Bad unit number in OPEN statement");
507 if (flags
.position
!= POSITION_UNSPECIFIED
508 && flags
.access
== ACCESS_DIRECT
)
509 generate_error (ERROR_BAD_OPTION
,
510 "Cannot use POSITION with direct access files");
512 if (flags
.position
== POSITION_UNSPECIFIED
)
513 flags
.position
= POSITION_ASIS
;
515 if (ioparm
.library_return
!= LIBRARY_OK
)
518 u
= find_unit (ioparm
.unit
);
523 already_open (u
, &flags
);