|
145
|
1 /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
|
|
111
|
2 Contributed by Andy Vaught
|
|
|
3 F2003 I/O support contributed by Jerry DeLisle
|
|
|
4
|
|
|
5 This file is part of the GNU Fortran 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 3, or (at your option)
|
|
|
10 any later version.
|
|
|
11
|
|
|
12 Libgfortran is distributed in the hope that it will be useful,
|
|
|
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
15 GNU General Public License for more details.
|
|
|
16
|
|
|
17 Under Section 7 of GPL version 3, you are granted additional
|
|
|
18 permissions described in the GCC Runtime Library Exception, version
|
|
|
19 3.1, as published by the Free Software Foundation.
|
|
|
20
|
|
|
21 You should have received a copy of the GNU General Public License and
|
|
|
22 a copy of the GCC Runtime Library Exception along with this program;
|
|
|
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
|
24 <http://www.gnu.org/licenses/>. */
|
|
|
25
|
|
|
26 #include "io.h"
|
|
|
27 #include "fbuf.h"
|
|
|
28 #include "unix.h"
|
|
131
|
29 #include "async.h"
|
|
111
|
30
|
|
|
31 #ifdef HAVE_UNISTD_H
|
|
|
32 #include <unistd.h>
|
|
|
33 #endif
|
|
|
34
|
|
|
35 #include <string.h>
|
|
|
36 #include <errno.h>
|
|
|
37
|
|
|
38
|
|
|
39 static const st_option access_opt[] = {
|
|
|
40 {"sequential", ACCESS_SEQUENTIAL},
|
|
|
41 {"direct", ACCESS_DIRECT},
|
|
|
42 {"append", ACCESS_APPEND},
|
|
|
43 {"stream", ACCESS_STREAM},
|
|
|
44 {NULL, 0}
|
|
|
45 };
|
|
|
46
|
|
|
47 static const st_option action_opt[] =
|
|
|
48 {
|
|
|
49 { "read", ACTION_READ},
|
|
|
50 { "write", ACTION_WRITE},
|
|
|
51 { "readwrite", ACTION_READWRITE},
|
|
|
52 { NULL, 0}
|
|
|
53 };
|
|
|
54
|
|
|
55 static const st_option share_opt[] =
|
|
|
56 {
|
|
|
57 { "denyrw", SHARE_DENYRW },
|
|
|
58 { "denynone", SHARE_DENYNONE },
|
|
|
59 { NULL, 0}
|
|
|
60 };
|
|
|
61
|
|
|
62 static const st_option cc_opt[] =
|
|
|
63 {
|
|
|
64 { "list", CC_LIST },
|
|
|
65 { "fortran", CC_FORTRAN },
|
|
|
66 { "none", CC_NONE },
|
|
|
67 { NULL, 0}
|
|
|
68 };
|
|
|
69
|
|
|
70 static const st_option blank_opt[] =
|
|
|
71 {
|
|
|
72 { "null", BLANK_NULL},
|
|
|
73 { "zero", BLANK_ZERO},
|
|
|
74 { NULL, 0}
|
|
|
75 };
|
|
|
76
|
|
|
77 static const st_option delim_opt[] =
|
|
|
78 {
|
|
|
79 { "none", DELIM_NONE},
|
|
|
80 { "apostrophe", DELIM_APOSTROPHE},
|
|
|
81 { "quote", DELIM_QUOTE},
|
|
|
82 { NULL, 0}
|
|
|
83 };
|
|
|
84
|
|
|
85 static const st_option form_opt[] =
|
|
|
86 {
|
|
|
87 { "formatted", FORM_FORMATTED},
|
|
|
88 { "unformatted", FORM_UNFORMATTED},
|
|
|
89 { NULL, 0}
|
|
|
90 };
|
|
|
91
|
|
|
92 static const st_option position_opt[] =
|
|
|
93 {
|
|
|
94 { "asis", POSITION_ASIS},
|
|
|
95 { "rewind", POSITION_REWIND},
|
|
|
96 { "append", POSITION_APPEND},
|
|
|
97 { NULL, 0}
|
|
|
98 };
|
|
|
99
|
|
|
100 static const st_option status_opt[] =
|
|
|
101 {
|
|
|
102 { "unknown", STATUS_UNKNOWN},
|
|
|
103 { "old", STATUS_OLD},
|
|
|
104 { "new", STATUS_NEW},
|
|
|
105 { "replace", STATUS_REPLACE},
|
|
|
106 { "scratch", STATUS_SCRATCH},
|
|
|
107 { NULL, 0}
|
|
|
108 };
|
|
|
109
|
|
|
110 static const st_option pad_opt[] =
|
|
|
111 {
|
|
|
112 { "yes", PAD_YES},
|
|
|
113 { "no", PAD_NO},
|
|
|
114 { NULL, 0}
|
|
|
115 };
|
|
|
116
|
|
|
117 static const st_option decimal_opt[] =
|
|
|
118 {
|
|
|
119 { "point", DECIMAL_POINT},
|
|
|
120 { "comma", DECIMAL_COMMA},
|
|
|
121 { NULL, 0}
|
|
|
122 };
|
|
|
123
|
|
|
124 static const st_option encoding_opt[] =
|
|
|
125 {
|
|
|
126 { "utf-8", ENCODING_UTF8},
|
|
|
127 { "default", ENCODING_DEFAULT},
|
|
|
128 { NULL, 0}
|
|
|
129 };
|
|
|
130
|
|
|
131 static const st_option round_opt[] =
|
|
|
132 {
|
|
|
133 { "up", ROUND_UP},
|
|
|
134 { "down", ROUND_DOWN},
|
|
|
135 { "zero", ROUND_ZERO},
|
|
|
136 { "nearest", ROUND_NEAREST},
|
|
|
137 { "compatible", ROUND_COMPATIBLE},
|
|
|
138 { "processor_defined", ROUND_PROCDEFINED},
|
|
|
139 { NULL, 0}
|
|
|
140 };
|
|
|
141
|
|
|
142 static const st_option sign_opt[] =
|
|
|
143 {
|
|
|
144 { "plus", SIGN_PLUS},
|
|
|
145 { "suppress", SIGN_SUPPRESS},
|
|
|
146 { "processor_defined", SIGN_PROCDEFINED},
|
|
|
147 { NULL, 0}
|
|
|
148 };
|
|
|
149
|
|
|
150 static const st_option convert_opt[] =
|
|
|
151 {
|
|
|
152 { "native", GFC_CONVERT_NATIVE},
|
|
|
153 { "swap", GFC_CONVERT_SWAP},
|
|
|
154 { "big_endian", GFC_CONVERT_BIG},
|
|
|
155 { "little_endian", GFC_CONVERT_LITTLE},
|
|
|
156 { NULL, 0}
|
|
|
157 };
|
|
|
158
|
|
|
159 static const st_option async_opt[] =
|
|
|
160 {
|
|
|
161 { "yes", ASYNC_YES},
|
|
|
162 { "no", ASYNC_NO},
|
|
|
163 { NULL, 0}
|
|
|
164 };
|
|
|
165
|
|
|
166 /* Given a unit, test to see if the file is positioned at the terminal
|
|
|
167 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
|
|
|
168 This prevents us from changing the state from AFTER_ENDFILE to
|
|
|
169 AT_ENDFILE. */
|
|
|
170
|
|
|
171 static void
|
|
|
172 test_endfile (gfc_unit *u)
|
|
|
173 {
|
|
|
174 if (u->endfile == NO_ENDFILE)
|
|
|
175 {
|
|
|
176 gfc_offset sz = ssize (u->s);
|
|
|
177 if (sz == 0 || sz == stell (u->s))
|
|
|
178 u->endfile = AT_ENDFILE;
|
|
|
179 }
|
|
|
180 }
|
|
|
181
|
|
|
182
|
|
|
183 /* Change the modes of a file, those that are allowed * to be
|
|
|
184 changed. */
|
|
|
185
|
|
|
186 static void
|
|
|
187 edit_modes (st_parameter_open *opp, gfc_unit *u, unit_flags *flags)
|
|
|
188 {
|
|
|
189 /* Complain about attempts to change the unchangeable. */
|
|
|
190
|
|
|
191 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
|
|
|
192 u->flags.status != flags->status)
|
|
|
193 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
194 "Cannot change STATUS parameter in OPEN statement");
|
|
|
195
|
|
|
196 if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
|
|
|
197 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
198 "Cannot change ACCESS parameter in OPEN statement");
|
|
|
199
|
|
|
200 if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
|
|
|
201 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
202 "Cannot change FORM parameter in OPEN statement");
|
|
|
203
|
|
|
204 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
|
|
|
205 && opp->recl_in != u->recl)
|
|
|
206 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
207 "Cannot change RECL parameter in OPEN statement");
|
|
|
208
|
|
|
209 if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
|
|
|
210 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
211 "Cannot change ACTION parameter in OPEN statement");
|
|
|
212
|
|
|
213 if (flags->share != SHARE_UNSPECIFIED && u->flags.share != flags->share)
|
|
|
214 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
215 "Cannot change SHARE parameter in OPEN statement");
|
|
|
216
|
|
|
217 if (flags->cc != CC_UNSPECIFIED && u->flags.cc != flags->cc)
|
|
|
218 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
219 "Cannot change CARRIAGECONTROL parameter in OPEN statement");
|
|
|
220
|
|
|
221 /* Status must be OLD if present. */
|
|
|
222
|
|
|
223 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
|
|
|
224 flags->status != STATUS_UNKNOWN)
|
|
|
225 {
|
|
|
226 if (flags->status == STATUS_SCRATCH)
|
|
|
227 notify_std (&opp->common, GFC_STD_GNU,
|
|
|
228 "OPEN statement must have a STATUS of OLD or UNKNOWN");
|
|
|
229 else
|
|
|
230 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
231 "OPEN statement must have a STATUS of OLD or UNKNOWN");
|
|
|
232 }
|
|
|
233
|
|
|
234 if (u->flags.form == FORM_UNFORMATTED)
|
|
|
235 {
|
|
|
236 if (flags->delim != DELIM_UNSPECIFIED)
|
|
|
237 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
238 "DELIM parameter conflicts with UNFORMATTED form in "
|
|
|
239 "OPEN statement");
|
|
|
240
|
|
|
241 if (flags->blank != BLANK_UNSPECIFIED)
|
|
|
242 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
243 "BLANK parameter conflicts with UNFORMATTED form in "
|
|
|
244 "OPEN statement");
|
|
|
245
|
|
|
246 if (flags->pad != PAD_UNSPECIFIED)
|
|
|
247 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
248 "PAD parameter conflicts with UNFORMATTED form in "
|
|
|
249 "OPEN statement");
|
|
|
250
|
|
|
251 if (flags->decimal != DECIMAL_UNSPECIFIED)
|
|
|
252 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
253 "DECIMAL parameter conflicts with UNFORMATTED form in "
|
|
|
254 "OPEN statement");
|
|
|
255
|
|
|
256 if (flags->encoding != ENCODING_UNSPECIFIED)
|
|
|
257 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
258 "ENCODING parameter conflicts with UNFORMATTED form in "
|
|
|
259 "OPEN statement");
|
|
|
260
|
|
|
261 if (flags->round != ROUND_UNSPECIFIED)
|
|
|
262 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
263 "ROUND parameter conflicts with UNFORMATTED form in "
|
|
|
264 "OPEN statement");
|
|
|
265
|
|
|
266 if (flags->sign != SIGN_UNSPECIFIED)
|
|
|
267 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
268 "SIGN parameter conflicts with UNFORMATTED form in "
|
|
|
269 "OPEN statement");
|
|
|
270 }
|
|
|
271
|
|
|
272 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
|
|
|
273 {
|
|
|
274 /* Change the changeable: */
|
|
|
275 if (flags->blank != BLANK_UNSPECIFIED)
|
|
|
276 u->flags.blank = flags->blank;
|
|
|
277 if (flags->delim != DELIM_UNSPECIFIED)
|
|
|
278 u->flags.delim = flags->delim;
|
|
|
279 if (flags->pad != PAD_UNSPECIFIED)
|
|
|
280 u->flags.pad = flags->pad;
|
|
|
281 if (flags->decimal != DECIMAL_UNSPECIFIED)
|
|
|
282 u->flags.decimal = flags->decimal;
|
|
|
283 if (flags->encoding != ENCODING_UNSPECIFIED)
|
|
|
284 u->flags.encoding = flags->encoding;
|
|
|
285 if (flags->async != ASYNC_UNSPECIFIED)
|
|
|
286 u->flags.async = flags->async;
|
|
|
287 if (flags->round != ROUND_UNSPECIFIED)
|
|
|
288 u->flags.round = flags->round;
|
|
|
289 if (flags->sign != SIGN_UNSPECIFIED)
|
|
|
290 u->flags.sign = flags->sign;
|
|
|
291
|
|
|
292 /* Reposition the file if necessary. */
|
|
|
293
|
|
|
294 switch (flags->position)
|
|
|
295 {
|
|
|
296 case POSITION_UNSPECIFIED:
|
|
|
297 case POSITION_ASIS:
|
|
|
298 break;
|
|
|
299
|
|
|
300 case POSITION_REWIND:
|
|
|
301 if (sseek (u->s, 0, SEEK_SET) != 0)
|
|
|
302 goto seek_error;
|
|
|
303
|
|
|
304 u->current_record = 0;
|
|
|
305 u->last_record = 0;
|
|
|
306
|
|
|
307 test_endfile (u);
|
|
|
308 break;
|
|
|
309
|
|
|
310 case POSITION_APPEND:
|
|
|
311 if (sseek (u->s, 0, SEEK_END) < 0)
|
|
|
312 goto seek_error;
|
|
|
313
|
|
|
314 if (flags->access != ACCESS_STREAM)
|
|
|
315 u->current_record = 0;
|
|
|
316
|
|
|
317 u->endfile = AT_ENDFILE; /* We are at the end. */
|
|
|
318 break;
|
|
|
319
|
|
|
320 seek_error:
|
|
|
321 generate_error (&opp->common, LIBERROR_OS, NULL);
|
|
|
322 break;
|
|
|
323 }
|
|
|
324 }
|
|
|
325
|
|
|
326 unlock_unit (u);
|
|
|
327 }
|
|
|
328
|
|
|
329
|
|
|
330 /* Open an unused unit. */
|
|
|
331
|
|
|
332 gfc_unit *
|
|
|
333 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags *flags)
|
|
|
334 {
|
|
|
335 gfc_unit *u2;
|
|
|
336 stream *s;
|
|
|
337 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
|
|
|
338
|
|
|
339 /* Change unspecifieds to defaults. Leave (flags->action ==
|
|
|
340 ACTION_UNSPECIFIED) alone so open_external() can set it based on
|
|
|
341 what type of open actually works. */
|
|
|
342
|
|
|
343 if (flags->access == ACCESS_UNSPECIFIED)
|
|
|
344 flags->access = ACCESS_SEQUENTIAL;
|
|
|
345
|
|
|
346 if (flags->form == FORM_UNSPECIFIED)
|
|
|
347 flags->form = (flags->access == ACCESS_SEQUENTIAL)
|
|
|
348 ? FORM_FORMATTED : FORM_UNFORMATTED;
|
|
|
349
|
|
|
350 if (flags->async == ASYNC_UNSPECIFIED)
|
|
|
351 flags->async = ASYNC_NO;
|
|
|
352
|
|
|
353 if (flags->status == STATUS_UNSPECIFIED)
|
|
|
354 flags->status = STATUS_UNKNOWN;
|
|
|
355
|
|
|
356 if (flags->cc == CC_UNSPECIFIED)
|
|
|
357 flags->cc = flags->form == FORM_UNFORMATTED ? CC_NONE : CC_LIST;
|
|
|
358 else if (flags->form == FORM_UNFORMATTED && flags->cc != CC_NONE)
|
|
|
359 {
|
|
|
360 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
361 "CARRIAGECONTROL parameter conflicts with UNFORMATTED form in "
|
|
|
362 "OPEN statement");
|
|
|
363 goto fail;
|
|
|
364 }
|
|
|
365
|
|
|
366 /* Checks. */
|
|
|
367
|
|
|
368 if (flags->delim != DELIM_UNSPECIFIED
|
|
|
369 && flags->form == FORM_UNFORMATTED)
|
|
|
370 {
|
|
|
371 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
372 "DELIM parameter conflicts with UNFORMATTED form in "
|
|
|
373 "OPEN statement");
|
|
|
374 goto fail;
|
|
|
375 }
|
|
|
376
|
|
|
377 if (flags->blank == BLANK_UNSPECIFIED)
|
|
|
378 flags->blank = BLANK_NULL;
|
|
|
379 else
|
|
|
380 {
|
|
|
381 if (flags->form == FORM_UNFORMATTED)
|
|
|
382 {
|
|
|
383 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
384 "BLANK parameter conflicts with UNFORMATTED form in "
|
|
|
385 "OPEN statement");
|
|
|
386 goto fail;
|
|
|
387 }
|
|
|
388 }
|
|
|
389
|
|
|
390 if (flags->pad == PAD_UNSPECIFIED)
|
|
|
391 flags->pad = PAD_YES;
|
|
|
392 else
|
|
|
393 {
|
|
|
394 if (flags->form == FORM_UNFORMATTED)
|
|
|
395 {
|
|
|
396 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
397 "PAD parameter conflicts with UNFORMATTED form in "
|
|
|
398 "OPEN statement");
|
|
|
399 goto fail;
|
|
|
400 }
|
|
|
401 }
|
|
|
402
|
|
|
403 if (flags->decimal == DECIMAL_UNSPECIFIED)
|
|
|
404 flags->decimal = DECIMAL_POINT;
|
|
|
405 else
|
|
|
406 {
|
|
|
407 if (flags->form == FORM_UNFORMATTED)
|
|
|
408 {
|
|
|
409 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
410 "DECIMAL parameter conflicts with UNFORMATTED form "
|
|
|
411 "in OPEN statement");
|
|
|
412 goto fail;
|
|
|
413 }
|
|
|
414 }
|
|
|
415
|
|
|
416 if (flags->encoding == ENCODING_UNSPECIFIED)
|
|
|
417 flags->encoding = ENCODING_DEFAULT;
|
|
|
418 else
|
|
|
419 {
|
|
|
420 if (flags->form == FORM_UNFORMATTED)
|
|
|
421 {
|
|
|
422 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
423 "ENCODING parameter conflicts with UNFORMATTED form in "
|
|
|
424 "OPEN statement");
|
|
|
425 goto fail;
|
|
|
426 }
|
|
|
427 }
|
|
|
428
|
|
|
429 /* NB: the value for ROUND when it's not specified by the user does not
|
|
|
430 have to be PROCESSOR_DEFINED; the standard says that it is
|
|
|
431 processor dependent, and requires that it is one of the
|
|
|
432 possible value (see F2003, 9.4.5.13). */
|
|
|
433 if (flags->round == ROUND_UNSPECIFIED)
|
|
|
434 flags->round = ROUND_PROCDEFINED;
|
|
|
435 else
|
|
|
436 {
|
|
|
437 if (flags->form == FORM_UNFORMATTED)
|
|
|
438 {
|
|
|
439 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
440 "ROUND parameter conflicts with UNFORMATTED form in "
|
|
|
441 "OPEN statement");
|
|
|
442 goto fail;
|
|
|
443 }
|
|
|
444 }
|
|
|
445
|
|
|
446 if (flags->sign == SIGN_UNSPECIFIED)
|
|
|
447 flags->sign = SIGN_PROCDEFINED;
|
|
|
448 else
|
|
|
449 {
|
|
|
450 if (flags->form == FORM_UNFORMATTED)
|
|
|
451 {
|
|
|
452 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
453 "SIGN parameter conflicts with UNFORMATTED form in "
|
|
|
454 "OPEN statement");
|
|
|
455 goto fail;
|
|
|
456 }
|
|
|
457 }
|
|
|
458
|
|
|
459 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
|
|
|
460 {
|
|
|
461 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
|
|
|
462 "ACCESS parameter conflicts with SEQUENTIAL access in "
|
|
|
463 "OPEN statement");
|
|
|
464 goto fail;
|
|
|
465 }
|
|
|
466 else
|
|
|
467 if (flags->position == POSITION_UNSPECIFIED)
|
|
|
468 flags->position = POSITION_ASIS;
|
|
|
469
|
|
|
470 if (flags->access == ACCESS_DIRECT
|
|
|
471 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
|
|
|
472 {
|
|
|
473 generate_error (&opp->common, LIBERROR_MISSING_OPTION,
|
|
|
474 "Missing RECL parameter in OPEN statement");
|
|
|
475 goto fail;
|
|
|
476 }
|
|
|
477
|
|
|
478 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
|
|
|
479 {
|
|
|
480 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
481 "RECL parameter is non-positive in OPEN statement");
|
|
|
482 goto fail;
|
|
|
483 }
|
|
|
484
|
|
|
485 switch (flags->status)
|
|
|
486 {
|
|
|
487 case STATUS_SCRATCH:
|
|
|
488 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
|
|
|
489 {
|
|
|
490 opp->file = NULL;
|
|
|
491 break;
|
|
|
492 }
|
|
|
493
|
|
|
494 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
495 "FILE parameter must not be present in OPEN statement");
|
|
|
496 goto fail;
|
|
|
497
|
|
|
498 case STATUS_OLD:
|
|
|
499 case STATUS_NEW:
|
|
|
500 case STATUS_REPLACE:
|
|
|
501 case STATUS_UNKNOWN:
|
|
|
502 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
|
|
|
503 break;
|
|
|
504
|
|
|
505 opp->file = tmpname;
|
|
|
506 opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
|
|
|
507 (int) opp->common.unit);
|
|
|
508 break;
|
|
|
509
|
|
|
510 default:
|
|
|
511 internal_error (&opp->common, "new_unit(): Bad status");
|
|
|
512 }
|
|
|
513
|
|
|
514 /* Make sure the file isn't already open someplace else.
|
|
|
515 Do not error if opening file preconnected to stdin, stdout, stderr. */
|
|
|
516
|
|
|
517 u2 = NULL;
|
|
145
|
518 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0
|
|
|
519 && !(compile_options.allow_std & GFC_STD_F2018))
|
|
111
|
520 u2 = find_file (opp->file, opp->file_len);
|
|
|
521 if (u2 != NULL
|
|
|
522 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
|
|
|
523 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
|
|
|
524 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
|
|
|
525 {
|
|
|
526 unlock_unit (u2);
|
|
|
527 generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
|
|
|
528 goto cleanup;
|
|
|
529 }
|
|
|
530
|
|
|
531 if (u2 != NULL)
|
|
|
532 unlock_unit (u2);
|
|
|
533
|
|
145
|
534 /* If the unit specified is preconnected with a file specified to be open,
|
|
|
535 then clear the format buffer. */
|
|
|
536 if ((opp->common.unit == options.stdin_unit ||
|
|
|
537 opp->common.unit == options.stdout_unit ||
|
|
|
538 opp->common.unit == options.stderr_unit)
|
|
|
539 && (opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
|
|
|
540 fbuf_destroy (u);
|
|
|
541
|
|
111
|
542 /* Open file. */
|
|
|
543
|
|
|
544 s = open_external (opp, flags);
|
|
|
545 if (s == NULL)
|
|
|
546 {
|
|
|
547 char errbuf[256];
|
|
|
548 char *path = fc_strdup (opp->file, opp->file_len);
|
|
|
549 size_t msglen = opp->file_len + 22 + sizeof (errbuf);
|
|
|
550 char *msg = xmalloc (msglen);
|
|
|
551 snprintf (msg, msglen, "Cannot open file '%s': %s", path,
|
|
|
552 gf_strerror (errno, errbuf, sizeof (errbuf)));
|
|
|
553 generate_error (&opp->common, LIBERROR_OS, msg);
|
|
|
554 free (msg);
|
|
|
555 free (path);
|
|
|
556 goto cleanup;
|
|
|
557 }
|
|
|
558
|
|
|
559 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
|
|
|
560 flags->status = STATUS_OLD;
|
|
|
561
|
|
|
562 /* Create the unit structure. */
|
|
|
563
|
|
|
564 if (u->unit_number != opp->common.unit)
|
|
|
565 internal_error (&opp->common, "Unit number changed");
|
|
|
566 u->s = s;
|
|
|
567 u->flags = *flags;
|
|
|
568 u->read_bad = 0;
|
|
|
569 u->endfile = NO_ENDFILE;
|
|
|
570 u->last_record = 0;
|
|
|
571 u->current_record = 0;
|
|
|
572 u->mode = READING;
|
|
|
573 u->maxrec = 0;
|
|
|
574 u->bytes_left = 0;
|
|
|
575 u->saved_pos = 0;
|
|
|
576
|
|
|
577 if (flags->position == POSITION_APPEND)
|
|
|
578 {
|
|
|
579 if (sseek (u->s, 0, SEEK_END) < 0)
|
|
|
580 {
|
|
|
581 generate_error (&opp->common, LIBERROR_OS, NULL);
|
|
|
582 goto cleanup;
|
|
|
583 }
|
|
|
584 u->endfile = AT_ENDFILE;
|
|
|
585 }
|
|
|
586
|
|
|
587 /* Unspecified recl ends up with a processor dependent value. */
|
|
|
588
|
|
|
589 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
|
|
|
590 {
|
|
|
591 u->flags.has_recl = 1;
|
|
|
592 u->recl = opp->recl_in;
|
|
|
593 u->recl_subrecord = u->recl;
|
|
|
594 u->bytes_left = u->recl;
|
|
|
595 }
|
|
|
596 else
|
|
|
597 {
|
|
|
598 u->flags.has_recl = 0;
|
|
131
|
599 u->recl = default_recl;
|
|
111
|
600 if (compile_options.max_subrecord_length)
|
|
|
601 {
|
|
|
602 u->recl_subrecord = compile_options.max_subrecord_length;
|
|
|
603 }
|
|
|
604 else
|
|
|
605 {
|
|
|
606 switch (compile_options.record_marker)
|
|
|
607 {
|
|
|
608 case 0:
|
|
|
609 /* Fall through */
|
|
|
610 case sizeof (GFC_INTEGER_4):
|
|
|
611 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
|
|
|
612 break;
|
|
|
613
|
|
|
614 case sizeof (GFC_INTEGER_8):
|
|
|
615 u->recl_subrecord = max_offset - 16;
|
|
|
616 break;
|
|
|
617
|
|
|
618 default:
|
|
|
619 runtime_error ("Illegal value for record marker");
|
|
|
620 break;
|
|
|
621 }
|
|
|
622 }
|
|
|
623 }
|
|
|
624
|
|
|
625 /* If the file is direct access, calculate the maximum record number
|
|
|
626 via a division now instead of letting the multiplication overflow
|
|
|
627 later. */
|
|
|
628
|
|
|
629 if (flags->access == ACCESS_DIRECT)
|
|
|
630 u->maxrec = max_offset / u->recl;
|
|
|
631
|
|
|
632 if (flags->access == ACCESS_STREAM)
|
|
|
633 {
|
|
|
634 u->maxrec = max_offset;
|
|
131
|
635 /* F2018 (N2137) 12.10.2.26: If the connection is for stream
|
|
|
636 access recl is assigned the value -2. */
|
|
|
637 u->recl = -2;
|
|
111
|
638 u->bytes_left = 1;
|
|
|
639 u->strm_pos = stell (u->s) + 1;
|
|
|
640 }
|
|
|
641
|
|
|
642 u->filename = fc_strdup (opp->file, opp->file_len);
|
|
|
643
|
|
|
644 /* Curiously, the standard requires that the
|
|
|
645 position specifier be ignored for new files so a newly connected
|
|
|
646 file starts out at the initial point. We still need to figure
|
|
|
647 out if the file is at the end or not. */
|
|
|
648
|
|
|
649 test_endfile (u);
|
|
|
650
|
|
|
651 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
|
|
|
652 free (opp->file);
|
|
|
653
|
|
|
654 if (flags->form == FORM_FORMATTED)
|
|
|
655 {
|
|
|
656 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
|
|
|
657 fbuf_init (u, u->recl);
|
|
|
658 else
|
|
|
659 fbuf_init (u, 0);
|
|
|
660 }
|
|
|
661 else
|
|
|
662 u->fbuf = NULL;
|
|
|
663
|
|
131
|
664 /* Check if asynchrounous. */
|
|
|
665 if (flags->async == ASYNC_YES)
|
|
|
666 init_async_unit (u);
|
|
|
667 else
|
|
|
668 u->au = NULL;
|
|
|
669
|
|
111
|
670 return u;
|
|
|
671
|
|
|
672 cleanup:
|
|
|
673
|
|
|
674 /* Free memory associated with a temporary filename. */
|
|
|
675
|
|
|
676 if (flags->status == STATUS_SCRATCH && opp->file != NULL)
|
|
|
677 free (opp->file);
|
|
|
678
|
|
|
679 fail:
|
|
|
680
|
|
|
681 close_unit (u);
|
|
|
682 return NULL;
|
|
|
683 }
|
|
|
684
|
|
|
685
|
|
|
686 /* Open a unit which is already open. This involves changing the
|
|
|
687 modes or closing what is there now and opening the new file. */
|
|
|
688
|
|
|
689 static void
|
|
|
690 already_open (st_parameter_open *opp, gfc_unit *u, unit_flags *flags)
|
|
|
691 {
|
|
|
692 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
|
|
|
693 {
|
|
|
694 edit_modes (opp, u, flags);
|
|
|
695 return;
|
|
|
696 }
|
|
|
697
|
|
|
698 /* If the file is connected to something else, close it and open a
|
|
|
699 new unit. */
|
|
|
700
|
|
|
701 if (!compare_file_filename (u, opp->file, opp->file_len))
|
|
|
702 {
|
|
|
703 if (sclose (u->s) == -1)
|
|
|
704 {
|
|
|
705 unlock_unit (u);
|
|
|
706 generate_error (&opp->common, LIBERROR_OS,
|
|
|
707 "Error closing file in OPEN statement");
|
|
|
708 return;
|
|
|
709 }
|
|
|
710
|
|
|
711 u->s = NULL;
|
|
|
712
|
|
|
713 #if !HAVE_UNLINK_OPEN_FILE
|
|
|
714 if (u->filename && u->flags.status == STATUS_SCRATCH)
|
|
|
715 remove (u->filename);
|
|
|
716 #endif
|
|
145
|
717 free (u->filename);
|
|
|
718 u->filename = NULL;
|
|
|
719
|
|
111
|
720 u = new_unit (opp, u, flags);
|
|
|
721 if (u != NULL)
|
|
145
|
722 unlock_unit (u);
|
|
111
|
723 return;
|
|
|
724 }
|
|
|
725
|
|
|
726 edit_modes (opp, u, flags);
|
|
|
727 }
|
|
|
728
|
|
|
729
|
|
|
730 /* Open file. */
|
|
|
731
|
|
|
732 extern void st_open (st_parameter_open *opp);
|
|
|
733 export_proto(st_open);
|
|
|
734
|
|
|
735 void
|
|
|
736 st_open (st_parameter_open *opp)
|
|
|
737 {
|
|
|
738 unit_flags flags;
|
|
|
739 gfc_unit *u = NULL;
|
|
|
740 GFC_INTEGER_4 cf = opp->common.flags;
|
|
|
741 unit_convert conv;
|
|
|
742
|
|
|
743 library_start (&opp->common);
|
|
|
744
|
|
|
745 /* Decode options. */
|
|
|
746 flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly;
|
|
|
747
|
|
|
748 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
|
|
|
749 find_option (&opp->common, opp->access, opp->access_len,
|
|
|
750 access_opt, "Bad ACCESS parameter in OPEN statement");
|
|
|
751
|
|
|
752 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
|
|
|
753 find_option (&opp->common, opp->action, opp->action_len,
|
|
|
754 action_opt, "Bad ACTION parameter in OPEN statement");
|
|
|
755
|
|
|
756 flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED :
|
|
|
757 find_option (&opp->common, opp->cc, opp->cc_len,
|
|
|
758 cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement");
|
|
|
759
|
|
|
760 flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED :
|
|
|
761 find_option (&opp->common, opp->share, opp->share_len,
|
|
|
762 share_opt, "Bad SHARE parameter in OPEN statement");
|
|
|
763
|
|
|
764 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
|
|
|
765 find_option (&opp->common, opp->blank, opp->blank_len,
|
|
|
766 blank_opt, "Bad BLANK parameter in OPEN statement");
|
|
|
767
|
|
|
768 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
|
|
|
769 find_option (&opp->common, opp->delim, opp->delim_len,
|
|
|
770 delim_opt, "Bad DELIM parameter in OPEN statement");
|
|
|
771
|
|
|
772 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
|
|
|
773 find_option (&opp->common, opp->pad, opp->pad_len,
|
|
|
774 pad_opt, "Bad PAD parameter in OPEN statement");
|
|
|
775
|
|
|
776 flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
|
|
|
777 find_option (&opp->common, opp->decimal, opp->decimal_len,
|
|
|
778 decimal_opt, "Bad DECIMAL parameter in OPEN statement");
|
|
|
779
|
|
|
780 flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
|
|
|
781 find_option (&opp->common, opp->encoding, opp->encoding_len,
|
|
|
782 encoding_opt, "Bad ENCODING parameter in OPEN statement");
|
|
|
783
|
|
|
784 flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
|
|
|
785 find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
|
|
|
786 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
|
|
|
787
|
|
|
788 flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
|
|
|
789 find_option (&opp->common, opp->round, opp->round_len,
|
|
|
790 round_opt, "Bad ROUND parameter in OPEN statement");
|
|
|
791
|
|
|
792 flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
|
|
|
793 find_option (&opp->common, opp->sign, opp->sign_len,
|
|
|
794 sign_opt, "Bad SIGN parameter in OPEN statement");
|
|
|
795
|
|
|
796 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
|
|
|
797 find_option (&opp->common, opp->form, opp->form_len,
|
|
|
798 form_opt, "Bad FORM parameter in OPEN statement");
|
|
|
799
|
|
|
800 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
|
|
|
801 find_option (&opp->common, opp->position, opp->position_len,
|
|
|
802 position_opt, "Bad POSITION parameter in OPEN statement");
|
|
|
803
|
|
|
804 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
|
|
|
805 find_option (&opp->common, opp->status, opp->status_len,
|
|
|
806 status_opt, "Bad STATUS parameter in OPEN statement");
|
|
|
807
|
|
|
808 /* First, we check wether the convert flag has been set via environment
|
|
|
809 variable. This overrides the convert tag in the open statement. */
|
|
|
810
|
|
|
811 conv = get_unformatted_convert (opp->common.unit);
|
|
|
812
|
|
|
813 if (conv == GFC_CONVERT_NONE)
|
|
|
814 {
|
|
|
815 /* Nothing has been set by environment variable, check the convert tag. */
|
|
|
816 if (cf & IOPARM_OPEN_HAS_CONVERT)
|
|
|
817 conv = find_option (&opp->common, opp->convert, opp->convert_len,
|
|
|
818 convert_opt,
|
|
|
819 "Bad CONVERT parameter in OPEN statement");
|
|
|
820 else
|
|
|
821 conv = compile_options.convert;
|
|
|
822 }
|
|
|
823
|
|
|
824 switch (conv)
|
|
|
825 {
|
|
|
826 case GFC_CONVERT_NATIVE:
|
|
|
827 case GFC_CONVERT_SWAP:
|
|
|
828 break;
|
|
|
829
|
|
|
830 case GFC_CONVERT_BIG:
|
|
131
|
831 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
|
|
111
|
832 break;
|
|
|
833
|
|
|
834 case GFC_CONVERT_LITTLE:
|
|
131
|
835 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
|
|
111
|
836 break;
|
|
|
837
|
|
|
838 default:
|
|
|
839 internal_error (&opp->common, "Illegal value for CONVERT");
|
|
|
840 break;
|
|
|
841 }
|
|
|
842
|
|
|
843 flags.convert = conv;
|
|
|
844
|
|
|
845 if (flags.position != POSITION_UNSPECIFIED
|
|
|
846 && flags.access == ACCESS_DIRECT)
|
|
|
847 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
848 "Cannot use POSITION with direct access files");
|
|
|
849
|
|
|
850 if (flags.readonly
|
|
|
851 && flags.action != ACTION_UNSPECIFIED && flags.action != ACTION_READ)
|
|
|
852 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
853 "ACTION conflicts with READONLY in OPEN statement");
|
|
|
854
|
|
|
855 if (flags.access == ACCESS_APPEND)
|
|
|
856 {
|
|
|
857 if (flags.position != POSITION_UNSPECIFIED
|
|
|
858 && flags.position != POSITION_APPEND)
|
|
|
859 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
860 "Conflicting ACCESS and POSITION flags in"
|
|
|
861 " OPEN statement");
|
|
|
862
|
|
|
863 notify_std (&opp->common, GFC_STD_GNU,
|
|
|
864 "Extension: APPEND as a value for ACCESS in OPEN statement");
|
|
|
865 flags.access = ACCESS_SEQUENTIAL;
|
|
|
866 flags.position = POSITION_APPEND;
|
|
|
867 }
|
|
|
868
|
|
|
869 if (flags.position == POSITION_UNSPECIFIED)
|
|
|
870 flags.position = POSITION_ASIS;
|
|
|
871
|
|
|
872 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
|
|
|
873 {
|
|
|
874 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
|
|
|
875 opp->common.unit = newunit_alloc ();
|
|
|
876 else if (opp->common.unit < 0)
|
|
|
877 {
|
|
|
878 u = find_unit (opp->common.unit);
|
|
|
879 if (u == NULL) /* Negative unit and no NEWUNIT-created unit found. */
|
|
|
880 {
|
|
|
881 generate_error (&opp->common, LIBERROR_BAD_OPTION,
|
|
|
882 "Bad unit number in OPEN statement");
|
|
|
883 library_end ();
|
|
|
884 return;
|
|
|
885 }
|
|
|
886 }
|
|
|
887
|
|
|
888 if (u == NULL)
|
|
|
889 u = find_or_create_unit (opp->common.unit);
|
|
|
890 if (u->s == NULL)
|
|
|
891 {
|
|
|
892 u = new_unit (opp, u, &flags);
|
|
|
893 if (u != NULL)
|
|
|
894 unlock_unit (u);
|
|
|
895 }
|
|
|
896 else
|
|
|
897 already_open (opp, u, &flags);
|
|
|
898 }
|
|
|
899
|
|
|
900 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
|
|
|
901 && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
|
|
|
902 *opp->newunit = opp->common.unit;
|
|
|
903
|
|
|
904 library_end ();
|
|
|
905 }
|
