]> gcc.gnu.org Git - gcc.git/blob - libgfortran/io/open.c
re PR libfortran/31099 (Runtime error on legal code using RECL)
[gcc.git] / libgfortran / io / open.c
1 /* Copyright (C) 2002, 2003, 2004, 2005
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
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)
10 any later version.
11
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
19 executable.)
20
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.
25
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. */
30
31 #include "config.h"
32 #include <unistd.h>
33 #include <stdio.h>
34 #include <string.h>
35 #include <errno.h>
36 #include "libgfortran.h"
37 #include "io.h"
38
39
40 static const st_option access_opt[] = {
41 {"sequential", ACCESS_SEQUENTIAL},
42 {"direct", ACCESS_DIRECT},
43 {"append", ACCESS_APPEND},
44 {"stream", ACCESS_STREAM},
45 {NULL, 0}
46 };
47
48 static const st_option action_opt[] =
49 {
50 { "read", ACTION_READ},
51 { "write", ACTION_WRITE},
52 { "readwrite", ACTION_READWRITE},
53 { NULL, 0}
54 };
55
56 static const st_option blank_opt[] =
57 {
58 { "null", BLANK_NULL},
59 { "zero", BLANK_ZERO},
60 { NULL, 0}
61 };
62
63 static const st_option delim_opt[] =
64 {
65 { "none", DELIM_NONE},
66 { "apostrophe", DELIM_APOSTROPHE},
67 { "quote", DELIM_QUOTE},
68 { NULL, 0}
69 };
70
71 static const st_option form_opt[] =
72 {
73 { "formatted", FORM_FORMATTED},
74 { "unformatted", FORM_UNFORMATTED},
75 { NULL, 0}
76 };
77
78 static const st_option position_opt[] =
79 {
80 { "asis", POSITION_ASIS},
81 { "rewind", POSITION_REWIND},
82 { "append", POSITION_APPEND},
83 { NULL, 0}
84 };
85
86 static const st_option status_opt[] =
87 {
88 { "unknown", STATUS_UNKNOWN},
89 { "old", STATUS_OLD},
90 { "new", STATUS_NEW},
91 { "replace", STATUS_REPLACE},
92 { "scratch", STATUS_SCRATCH},
93 { NULL, 0}
94 };
95
96 static const st_option pad_opt[] =
97 {
98 { "yes", PAD_YES},
99 { "no", PAD_NO},
100 { NULL, 0}
101 };
102
103 static const st_option convert_opt[] =
104 {
105 { "native", CONVERT_NATIVE},
106 { "swap", CONVERT_SWAP},
107 { "big_endian", CONVERT_BIG},
108 { "little_endian", CONVERT_LITTLE},
109 { NULL, 0}
110 };
111
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
115 AT_ENDFILE. */
116
117 void
118 test_endfile (gfc_unit * u)
119 {
120 if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
121 u->endfile = AT_ENDFILE;
122 }
123
124
125 /* Change the modes of a file, those that are allowed * to be
126 changed. */
127
128 static void
129 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
130 {
131 /* Complain about attempts to change the unchangeable. */
132
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");
137
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");
141
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");
145
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");
150
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");
154
155 /* Status must be OLD if present. */
156
157 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
158 flags->status != STATUS_UNKNOWN)
159 {
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");
163 else
164 generate_error (&opp->common, ERROR_BAD_OPTION,
165 "OPEN statement must have a STATUS of OLD or UNKNOWN");
166 }
167
168 if (u->flags.form == FORM_UNFORMATTED)
169 {
170 if (flags->delim != DELIM_UNSPECIFIED)
171 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
172 "DELIM parameter conflicts with UNFORMATTED form in "
173 "OPEN statement");
174
175 if (flags->blank != BLANK_UNSPECIFIED)
176 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
177 "BLANK parameter conflicts with UNFORMATTED form in "
178 "OPEN statement");
179
180 if (flags->pad != PAD_UNSPECIFIED)
181 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
182 "PAD parameter conflicts with UNFORMATTED form in "
183 "OPEN statement");
184 }
185
186 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
187 {
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;
195 }
196
197 /* Reposition the file if necessary. */
198
199 switch (flags->position)
200 {
201 case POSITION_UNSPECIFIED:
202 case POSITION_ASIS:
203 break;
204
205 case POSITION_REWIND:
206 if (sseek (u->s, 0) == FAILURE)
207 goto seek_error;
208
209 u->current_record = 0;
210 u->last_record = 0;
211
212 test_endfile (u); /* We might be at the end. */
213 break;
214
215 case POSITION_APPEND:
216 if (sseek (u->s, file_length (u->s)) == FAILURE)
217 goto seek_error;
218
219 if (flags->access != ACCESS_STREAM)
220 u->current_record = 0;
221
222 u->endfile = AT_ENDFILE; /* We are at the end. */
223 break;
224
225 seek_error:
226 generate_error (&opp->common, ERROR_OS, NULL);
227 break;
228 }
229
230 unlock_unit (u);
231 }
232
233
234 /* Open an unused unit. */
235
236 gfc_unit *
237 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
238 {
239 gfc_unit *u2;
240 stream *s;
241 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
242
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. */
246
247 if (flags->access == ACCESS_UNSPECIFIED)
248 flags->access = ACCESS_SEQUENTIAL;
249
250 if (flags->form == FORM_UNSPECIFIED)
251 flags->form = (flags->access == ACCESS_SEQUENTIAL)
252 ? FORM_FORMATTED : FORM_UNFORMATTED;
253
254
255 if (flags->delim == DELIM_UNSPECIFIED)
256 flags->delim = DELIM_NONE;
257 else
258 {
259 if (flags->form == FORM_UNFORMATTED)
260 {
261 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
262 "DELIM parameter conflicts with UNFORMATTED form in "
263 "OPEN statement");
264 goto fail;
265 }
266 }
267
268 if (flags->blank == BLANK_UNSPECIFIED)
269 flags->blank = BLANK_NULL;
270 else
271 {
272 if (flags->form == FORM_UNFORMATTED)
273 {
274 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
275 "BLANK parameter conflicts with UNFORMATTED form in "
276 "OPEN statement");
277 goto fail;
278 }
279 }
280
281 if (flags->pad == PAD_UNSPECIFIED)
282 flags->pad = PAD_YES;
283 else
284 {
285 if (flags->form == FORM_UNFORMATTED)
286 {
287 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
288 "PAD parameter conflicts with UNFORMATTED form in "
289 "OPEN statement");
290 goto fail;
291 }
292 }
293
294 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
295 {
296 generate_error (&opp->common, ERROR_OPTION_CONFLICT,
297 "ACCESS parameter conflicts with SEQUENTIAL access in "
298 "OPEN statement");
299 goto fail;
300 }
301 else
302 if (flags->position == POSITION_UNSPECIFIED)
303 flags->position = POSITION_ASIS;
304
305
306 if (flags->status == STATUS_UNSPECIFIED)
307 flags->status = STATUS_UNKNOWN;
308
309 /* Checks. */
310
311 if (flags->access == ACCESS_DIRECT
312 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
313 {
314 generate_error (&opp->common, ERROR_MISSING_OPTION,
315 "Missing RECL parameter in OPEN statement");
316 goto fail;
317 }
318
319 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
320 {
321 generate_error (&opp->common, ERROR_BAD_OPTION,
322 "RECL parameter is non-positive in OPEN statement");
323 goto fail;
324 }
325
326 switch (flags->status)
327 {
328 case STATUS_SCRATCH:
329 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
330 {
331 opp->file = NULL;
332 break;
333 }
334
335 generate_error (&opp->common, ERROR_BAD_OPTION,
336 "FILE parameter must not be present in OPEN statement");
337 goto fail;
338
339 case STATUS_OLD:
340 case STATUS_NEW:
341 case STATUS_REPLACE:
342 case STATUS_UNKNOWN:
343 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
344 break;
345
346 opp->file = tmpname;
347 opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
348 break;
349
350 default:
351 internal_error (&opp->common, "new_unit(): Bad status");
352 }
353
354 /* Make sure the file isn't already open someplace else.
355 Do not error if opening file preconnected to stdin, stdout, stderr. */
356
357 u2 = NULL;
358 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
359 u2 = find_file (opp->file, opp->file_len);
360 if (u2 != NULL
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))
364 {
365 unlock_unit (u2);
366 generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
367 goto cleanup;
368 }
369
370 if (u2 != NULL)
371 unlock_unit (u2);
372
373 /* Open file. */
374
375 s = open_external (opp, flags);
376 if (s == NULL)
377 {
378 char *path, *msg;
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);
382
383 switch (errno)
384 {
385 case ENOENT:
386 st_sprintf (msg, "File '%s' does not exist", path);
387 break;
388
389 case EEXIST:
390 st_sprintf (msg, "File '%s' already exists", path);
391 break;
392
393 case EACCES:
394 st_sprintf (msg, "Permission denied trying to open file '%s'", path);
395 break;
396
397 case EISDIR:
398 st_sprintf (msg, "'%s' is a directory", path);
399 break;
400
401 default:
402 msg = NULL;
403 }
404
405 generate_error (&opp->common, ERROR_OS, msg);
406 goto cleanup;
407 }
408
409 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
410 flags->status = STATUS_OLD;
411
412 /* Create the unit structure. */
413
414 u->file = get_mem (opp->file_len);
415 if (u->unit_number != opp->common.unit)
416 internal_error (&opp->common, "Unit number changed");
417 u->s = s;
418 u->flags = *flags;
419 u->read_bad = 0;
420 u->endfile = NO_ENDFILE;
421 u->last_record = 0;
422 u->current_record = 0;
423 u->mode = READING;
424 u->maxrec = 0;
425 u->bytes_left = 0;
426
427 if (flags->position == POSITION_APPEND)
428 {
429 if (sseek (u->s, file_length (u->s)) == FAILURE)
430 generate_error (&opp->common, ERROR_OS, NULL);
431 u->endfile = AT_ENDFILE;
432 }
433
434 /* Unspecified recl ends up with a processor dependent value. */
435
436 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
437 {
438 u->flags.has_recl = 1;
439 u->recl = opp->recl_in;
440 u->recl_subrecord = u->recl;
441 u->bytes_left = u->recl;
442 }
443 else
444 {
445 u->flags.has_recl = 0;
446 u->recl = max_offset;
447 if (compile_options.max_subrecord_length)
448 {
449 u->recl_subrecord = compile_options.max_subrecord_length;
450 }
451 else
452 {
453 switch (compile_options.record_marker)
454 {
455 case 0:
456 /* Fall through */
457 case sizeof (GFC_INTEGER_4):
458 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
459 break;
460
461 case sizeof (GFC_INTEGER_8):
462 u->recl_subrecord = max_offset - 16;
463 break;
464
465 default:
466 runtime_error ("Illegal value for record marker");
467 break;
468 }
469 }
470 }
471
472 /* If the file is direct access, calculate the maximum record number
473 via a division now instead of letting the multiplication overflow
474 later. */
475
476 if (flags->access == ACCESS_DIRECT)
477 u->maxrec = max_offset / u->recl;
478
479 if (flags->access == ACCESS_STREAM)
480 {
481 u->maxrec = max_offset;
482 u->recl = 1;
483 u->strm_pos = 1;
484 }
485
486 memmove (u->file, opp->file, opp->file_len);
487 u->file_len = opp->file_len;
488
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. */
493
494 test_endfile (u);
495
496 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
497 free_mem (opp->file);
498 return u;
499
500 cleanup:
501
502 /* Free memory associated with a temporary filename. */
503
504 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
505 free_mem (opp->file);
506
507 fail:
508
509 close_unit (u);
510 return NULL;
511 }
512
513
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. */
516
517 static void
518 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
519 {
520 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
521 {
522 edit_modes (opp, u, flags);
523 return;
524 }
525
526 /* If the file is connected to something else, close it and open a
527 new unit. */
528
529 if (!compare_file_filename (u, opp->file, opp->file_len))
530 {
531 #if !HAVE_UNLINK_OPEN_FILE
532 char *path = NULL;
533 if (u->file && u->flags.status == STATUS_SCRATCH)
534 {
535 path = (char *) gfc_alloca (u->file_len + 1);
536 unpack_filename (path, u->file, u->file_len);
537 }
538 #endif
539
540 if (sclose (u->s) == FAILURE)
541 {
542 unlock_unit (u);
543 generate_error (&opp->common, ERROR_OS,
544 "Error closing file in OPEN statement");
545 return;
546 }
547
548 u->s = NULL;
549 if (u->file)
550 free_mem (u->file);
551 u->file = NULL;
552 u->file_len = 0;
553
554 #if !HAVE_UNLINK_OPEN_FILE
555 if (path != NULL)
556 unlink (path);
557 #endif
558
559 u = new_unit (opp, u, flags);
560 if (u != NULL)
561 unlock_unit (u);
562 return;
563 }
564
565 edit_modes (opp, u, flags);
566 }
567
568
569 /* Open file. */
570
571 extern void st_open (st_parameter_open *opp);
572 export_proto(st_open);
573
574 void
575 st_open (st_parameter_open *opp)
576 {
577 unit_flags flags;
578 gfc_unit *u = NULL;
579 GFC_INTEGER_4 cf = opp->common.flags;
580 unit_convert conv;
581
582 library_start (&opp->common);
583
584 /* Decode options. */
585
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");
589
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");
593
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");
597
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");
601
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");
605
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");
609
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");
613
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");
617
618 /* First, we check wether the convert flag has been set via environment
619 variable. This overrides the convert tag in the open statement. */
620
621 conv = get_unformatted_convert (opp->common.unit);
622
623 if (conv == CONVERT_NONE)
624 {
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,
628 convert_opt,
629 "Bad CONVERT parameter in OPEN statement");
630 else
631 conv = compile_options.convert;
632 }
633
634 /* We use l8_to_l4_offset, which is 0 on little-endian machines
635 and 1 on big-endian machines. */
636 switch (conv)
637 {
638 case CONVERT_NATIVE:
639 case CONVERT_SWAP:
640 break;
641
642 case CONVERT_BIG:
643 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
644 break;
645
646 case CONVERT_LITTLE:
647 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
648 break;
649
650 default:
651 internal_error (&opp->common, "Illegal value for CONVERT");
652 break;
653 }
654
655 flags.convert = conv;
656
657 if (opp->common.unit < 0)
658 generate_error (&opp->common, ERROR_BAD_OPTION,
659 "Bad unit number in OPEN statement");
660
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");
665
666 if (flags.access == ACCESS_APPEND)
667 {
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"
672 " OPEN statement");
673
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;
678 }
679
680 if (flags.position == POSITION_UNSPECIFIED)
681 flags.position = POSITION_ASIS;
682
683 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
684 {
685 u = find_or_create_unit (opp->common.unit);
686
687 if (u->s == NULL)
688 {
689 u = new_unit (opp, u, &flags);
690 if (u != NULL)
691 unlock_unit (u);
692 }
693 else
694 already_open (opp, u, &flags);
695 }
696
697 library_end ();
698 }
This page took 2.795603 seconds and 6 git commands to generate.