]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Deal with I/O statements & related stuff. |
8d9254fc | 2 | Copyright (C) 2000-2020 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Andy Vaught |
4 | ||
9fc4d79b | 5 | This file is part of GCC. |
6de9cd9a | 6 | |
9fc4d79b TS |
7 | GCC is free software; you can redistribute it and/or modify it under |
8 | the terms of the GNU General Public License as published by the Free | |
d234d788 | 9 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 10 | version. |
6de9cd9a | 11 | |
9fc4d79b TS |
12 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
13 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 | for more details. | |
6de9cd9a DN |
16 | |
17 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
18 | along with GCC; see the file COPYING3. If not see |
19 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
20 | |
21 | #include "config.h" | |
22 | #include "system.h" | |
953bee7c | 23 | #include "coretypes.h" |
1916bcb5 | 24 | #include "options.h" |
6de9cd9a DN |
25 | #include "gfortran.h" |
26 | #include "match.h" | |
27 | #include "parse.h" | |
a48718a2 | 28 | #include "constructor.h" |
6de9cd9a | 29 | |
b251af97 SK |
30 | gfc_st_label |
31 | format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, | |
388902da | 32 | 0, {NULL, NULL}, NULL}; |
6de9cd9a DN |
33 | |
34 | typedef struct | |
35 | { | |
9b8d1901 | 36 | const char *name, *spec, *value; |
6de9cd9a DN |
37 | bt type; |
38 | } | |
39 | io_tag; | |
40 | ||
41 | static const io_tag | |
0ef33d44 FR |
42 | tag_readonly = {"READONLY", " readonly", NULL, BT_UNKNOWN }, |
43 | tag_shared = {"SHARE", " shared", NULL, BT_UNKNOWN }, | |
44 | tag_noshared = {"SHARE", " noshared", NULL, BT_UNKNOWN }, | |
45 | tag_e_share = {"SHARE", " share =", " %e", BT_CHARACTER }, | |
46 | tag_v_share = {"SHARE", " share =", " %v", BT_CHARACTER }, | |
47 | tag_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %e", | |
48 | BT_CHARACTER }, | |
49 | tag_v_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %v", | |
50 | BT_CHARACTER }, | |
9ad55c33 JD |
51 | tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, |
52 | tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, | |
9b8d1901 TS |
53 | tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, |
54 | tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER}, | |
55 | tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER}, | |
56 | tag_e_blank = {"BLANK", " blank =", " %e", BT_CHARACTER}, | |
57 | tag_e_position = {"POSITION", " position =", " %e", BT_CHARACTER}, | |
58 | tag_e_action = {"ACTION", " action =", " %e", BT_CHARACTER}, | |
59 | tag_e_delim = {"DELIM", " delim =", " %e", BT_CHARACTER}, | |
60 | tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER}, | |
61 | tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER}, | |
62 | tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER}, | |
d06b3496 | 63 | tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER}, |
9b8d1901 TS |
64 | tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER}, |
65 | tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER}, | |
66 | tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER}, | |
67 | tag_advance = {"ADVANCE", " advance =", " %e", BT_CHARACTER}, | |
68 | tag_rec = {"REC", " rec =", " %e", BT_INTEGER}, | |
69 | tag_spos = {"POSITION", " pos =", " %e", BT_INTEGER}, | |
70 | tag_format = {"FORMAT", NULL, NULL, BT_CHARACTER}, | |
71 | tag_iomsg = {"IOMSG", " iomsg =", " %e", BT_CHARACTER}, | |
72 | tag_iostat = {"IOSTAT", " iostat =", " %v", BT_INTEGER}, | |
73 | tag_size = {"SIZE", " size =", " %v", BT_INTEGER}, | |
74 | tag_exist = {"EXIST", " exist =", " %v", BT_LOGICAL}, | |
75 | tag_opened = {"OPENED", " opened =", " %v", BT_LOGICAL}, | |
76 | tag_named = {"NAMED", " named =", " %v", BT_LOGICAL}, | |
77 | tag_name = {"NAME", " name =", " %v", BT_CHARACTER}, | |
78 | tag_number = {"NUMBER", " number =", " %v", BT_INTEGER}, | |
79 | tag_s_access = {"ACCESS", " access =", " %v", BT_CHARACTER}, | |
80 | tag_sequential = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER}, | |
81 | tag_direct = {"DIRECT", " direct =", " %v", BT_CHARACTER}, | |
82 | tag_s_form = {"FORM", " form =", " %v", BT_CHARACTER}, | |
83 | tag_formatted = {"FORMATTED", " formatted =", " %v", BT_CHARACTER}, | |
84 | tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER}, | |
85 | tag_s_recl = {"RECL", " recl =", " %v", BT_INTEGER}, | |
86 | tag_nextrec = {"NEXTREC", " nextrec =", " %v", BT_INTEGER}, | |
87 | tag_s_blank = {"BLANK", " blank =", " %v", BT_CHARACTER}, | |
88 | tag_s_position = {"POSITION", " position =", " %v", BT_CHARACTER}, | |
89 | tag_s_action = {"ACTION", " action =", " %v", BT_CHARACTER}, | |
90 | tag_read = {"READ", " read =", " %v", BT_CHARACTER}, | |
91 | tag_write = {"WRITE", " write =", " %v", BT_CHARACTER}, | |
92 | tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER}, | |
93 | tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER}, | |
94 | tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER}, | |
d06b3496 JD |
95 | tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER}, |
96 | tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER}, | |
97 | tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER}, | |
98 | tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER}, | |
99 | tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER}, | |
9b8d1901 TS |
100 | tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER}, |
101 | tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER}, | |
102 | tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER}, | |
103 | tag_err = {"ERR", " err =", " %l", BT_UNKNOWN}, | |
104 | tag_end = {"END", " end =", " %l", BT_UNKNOWN}, | |
105 | tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN}, | |
d06b3496 | 106 | tag_id = {"ID", " id =", " %v", BT_INTEGER}, |
9ad55c33 | 107 | tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}, |
93e8af19 JD |
108 | tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER}, |
109 | tag_s_iqstream = {"STREAM", " stream =", " %v", BT_CHARACTER}; | |
6de9cd9a DN |
110 | |
111 | static gfc_dt *current_dt; | |
112 | ||
524af0d6 | 113 | #define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false; |
6de9cd9a | 114 | |
6de9cd9a DN |
115 | /**************** Fortran 95 FORMAT parser *****************/ |
116 | ||
117 | /* FORMAT tokens returned by format_lex(). */ | |
a79683d5 | 118 | enum format_token |
6de9cd9a DN |
119 | { |
120 | FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, | |
74657812 | 121 | FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, |
6de9cd9a | 122 | FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, |
de1ee8e1 | 123 | FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, |
f2a71504 | 124 | FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC, |
e73d3ca6 | 125 | FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT |
a79683d5 | 126 | }; |
6de9cd9a DN |
127 | |
128 | /* Local variables for checking format strings. The saved_token is | |
129 | used to back up by a single format token during the parsing | |
130 | process. */ | |
00660189 | 131 | static gfc_char_t *format_string; |
c8129db1 | 132 | static int format_string_pos; |
6de9cd9a | 133 | static int format_length, use_last_char; |
9cad01ce DK |
134 | static char error_element; |
135 | static locus format_locus; | |
6de9cd9a DN |
136 | |
137 | static format_token saved_token; | |
138 | ||
139 | static enum | |
140 | { MODE_STRING, MODE_FORMAT, MODE_COPY } | |
141 | mode; | |
142 | ||
143 | ||
144 | /* Return the next character in the format string. */ | |
145 | ||
146 | static char | |
696abb30 | 147 | next_char (gfc_instring in_string) |
6de9cd9a | 148 | { |
8fc541d3 | 149 | static gfc_char_t c; |
6de9cd9a DN |
150 | |
151 | if (use_last_char) | |
152 | { | |
153 | use_last_char = 0; | |
154 | return c; | |
155 | } | |
156 | ||
157 | format_length++; | |
158 | ||
159 | if (mode == MODE_STRING) | |
160 | c = *format_string++; | |
161 | else | |
162 | { | |
163 | c = gfc_next_char_literal (in_string); | |
164 | if (c == '\n') | |
165 | c = '\0'; | |
2e6a83a7 SK |
166 | } |
167 | ||
c61819ff | 168 | if (flag_backslash && c == '\\') |
2e6a83a7 SK |
169 | { |
170 | locus old_locus = gfc_current_locus; | |
6de9cd9a | 171 | |
8fc541d3 | 172 | if (gfc_match_special_char (&c) == MATCH_NO) |
a88a266c SK |
173 | gfc_current_locus = old_locus; |
174 | ||
2e6a83a7 | 175 | if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) |
db30e21c | 176 | gfc_warning (0, "Extension: backslash character at %C"); |
6de9cd9a DN |
177 | } |
178 | ||
2e6a83a7 SK |
179 | if (mode == MODE_COPY) |
180 | *format_string++ = c; | |
181 | ||
9cad01ce DK |
182 | if (mode != MODE_STRING) |
183 | format_locus = gfc_current_locus; | |
184 | ||
c8129db1 JD |
185 | format_string_pos++; |
186 | ||
00660189 | 187 | c = gfc_wide_toupper (c); |
6de9cd9a DN |
188 | return c; |
189 | } | |
190 | ||
191 | ||
192 | /* Back up one character position. Only works once. */ | |
193 | ||
194 | static void | |
195 | unget_char (void) | |
196 | { | |
6de9cd9a DN |
197 | use_last_char = 1; |
198 | } | |
199 | ||
66e4ab31 | 200 | /* Eat up the spaces and return a character. */ |
df3c4c81 JD |
201 | |
202 | static char | |
99c72130 | 203 | next_char_not_space () |
df3c4c81 JD |
204 | { |
205 | char c; | |
206 | do | |
207 | { | |
696abb30 | 208 | error_element = c = next_char (NONSTRING); |
c2df0359 | 209 | if (c == '\t') |
99c72130 | 210 | gfc_warning (OPT_Wtabs, "Nonconforming tab character in format at %C"); |
df3c4c81 JD |
211 | } |
212 | while (gfc_is_whitespace (c)); | |
213 | return c; | |
214 | } | |
215 | ||
6de9cd9a DN |
216 | static int value = 0; |
217 | ||
218 | /* Simple lexical analyzer for getting the next token in a FORMAT | |
219 | statement. */ | |
220 | ||
221 | static format_token | |
222 | format_lex (void) | |
223 | { | |
224 | format_token token; | |
225 | char c, delim; | |
226 | int zflag; | |
227 | int negative_flag; | |
228 | ||
229 | if (saved_token != FMT_NONE) | |
230 | { | |
231 | token = saved_token; | |
232 | saved_token = FMT_NONE; | |
233 | return token; | |
234 | } | |
235 | ||
99c72130 | 236 | c = next_char_not_space (); |
df3c4c81 | 237 | |
6de9cd9a DN |
238 | negative_flag = 0; |
239 | switch (c) | |
240 | { | |
241 | case '-': | |
242 | negative_flag = 1; | |
efb63364 TB |
243 | /* Falls through. */ |
244 | ||
6de9cd9a | 245 | case '+': |
99c72130 | 246 | c = next_char_not_space (); |
6de9cd9a DN |
247 | if (!ISDIGIT (c)) |
248 | { | |
249 | token = FMT_UNKNOWN; | |
250 | break; | |
251 | } | |
252 | ||
253 | value = c - '0'; | |
254 | ||
255 | do | |
256 | { | |
99c72130 | 257 | c = next_char_not_space (); |
b251af97 SK |
258 | if (ISDIGIT (c)) |
259 | value = 10 * value + c - '0'; | |
6de9cd9a DN |
260 | } |
261 | while (ISDIGIT (c)); | |
262 | ||
263 | unget_char (); | |
264 | ||
265 | if (negative_flag) | |
b251af97 | 266 | value = -value; |
6de9cd9a DN |
267 | |
268 | token = FMT_SIGNED_INT; | |
269 | break; | |
270 | ||
271 | case '0': | |
272 | case '1': | |
273 | case '2': | |
274 | case '3': | |
275 | case '4': | |
276 | case '5': | |
277 | case '6': | |
278 | case '7': | |
279 | case '8': | |
280 | case '9': | |
281 | zflag = (c == '0'); | |
282 | ||
283 | value = c - '0'; | |
284 | ||
285 | do | |
286 | { | |
99c72130 | 287 | c = next_char_not_space (); |
b251af97 | 288 | if (ISDIGIT (c)) |
e444a887 TB |
289 | { |
290 | value = 10 * value + c - '0'; | |
291 | if (c != '0') | |
292 | zflag = 0; | |
293 | } | |
6de9cd9a | 294 | } |
df3c4c81 | 295 | while (ISDIGIT (c)); |
6de9cd9a DN |
296 | |
297 | unget_char (); | |
298 | token = zflag ? FMT_ZERO : FMT_POSINT; | |
299 | break; | |
300 | ||
301 | case '.': | |
302 | token = FMT_PERIOD; | |
303 | break; | |
304 | ||
305 | case ',': | |
306 | token = FMT_COMMA; | |
307 | break; | |
308 | ||
309 | case ':': | |
310 | token = FMT_COLON; | |
311 | break; | |
312 | ||
313 | case '/': | |
314 | token = FMT_SLASH; | |
315 | break; | |
316 | ||
317 | case '$': | |
318 | token = FMT_DOLLAR; | |
319 | break; | |
320 | ||
321 | case 'T': | |
99c72130 | 322 | c = next_char_not_space (); |
74657812 JD |
323 | switch (c) |
324 | { | |
325 | case 'L': | |
326 | token = FMT_TL; | |
327 | break; | |
328 | case 'R': | |
329 | token = FMT_TR; | |
330 | break; | |
331 | default: | |
332 | token = FMT_T; | |
333 | unget_char (); | |
334 | } | |
6de9cd9a DN |
335 | break; |
336 | ||
337 | case '(': | |
338 | token = FMT_LPAREN; | |
339 | break; | |
340 | ||
341 | case ')': | |
342 | token = FMT_RPAREN; | |
343 | break; | |
344 | ||
345 | case 'X': | |
346 | token = FMT_X; | |
347 | break; | |
348 | ||
349 | case 'S': | |
99c72130 | 350 | c = next_char_not_space (); |
6de9cd9a DN |
351 | if (c != 'P' && c != 'S') |
352 | unget_char (); | |
353 | ||
354 | token = FMT_SIGN; | |
355 | break; | |
356 | ||
357 | case 'B': | |
99c72130 | 358 | c = next_char_not_space (); |
6de9cd9a DN |
359 | if (c == 'N' || c == 'Z') |
360 | token = FMT_BLANK; | |
361 | else | |
362 | { | |
363 | unget_char (); | |
364 | token = FMT_IBOZ; | |
365 | } | |
366 | ||
367 | break; | |
368 | ||
369 | case '\'': | |
370 | case '"': | |
371 | delim = c; | |
372 | ||
373 | value = 0; | |
374 | ||
375 | for (;;) | |
376 | { | |
696abb30 | 377 | c = next_char (INSTRING_WARN); |
6de9cd9a DN |
378 | if (c == '\0') |
379 | { | |
380 | token = FMT_END; | |
381 | break; | |
382 | } | |
383 | ||
384 | if (c == delim) | |
385 | { | |
c55bbc72 | 386 | c = next_char (NONSTRING); |
6de9cd9a DN |
387 | |
388 | if (c == '\0') | |
389 | { | |
390 | token = FMT_END; | |
391 | break; | |
392 | } | |
393 | ||
394 | if (c != delim) | |
395 | { | |
396 | unget_char (); | |
397 | token = FMT_CHAR; | |
398 | break; | |
399 | } | |
400 | } | |
b251af97 | 401 | value++; |
6de9cd9a DN |
402 | } |
403 | break; | |
404 | ||
405 | case 'P': | |
406 | token = FMT_P; | |
407 | break; | |
408 | ||
409 | case 'I': | |
410 | case 'O': | |
411 | case 'Z': | |
412 | token = FMT_IBOZ; | |
413 | break; | |
414 | ||
415 | case 'F': | |
416 | token = FMT_F; | |
417 | break; | |
418 | ||
419 | case 'E': | |
99c72130 | 420 | c = next_char_not_space (); |
de1ee8e1 JD |
421 | if (c == 'N' ) |
422 | token = FMT_EN; | |
423 | else if (c == 'S') | |
424 | token = FMT_ES; | |
6de9cd9a DN |
425 | else |
426 | { | |
427 | token = FMT_E; | |
428 | unget_char (); | |
429 | } | |
430 | ||
431 | break; | |
432 | ||
433 | case 'G': | |
434 | token = FMT_G; | |
435 | break; | |
436 | ||
437 | case 'H': | |
438 | token = FMT_H; | |
439 | break; | |
440 | ||
441 | case 'L': | |
442 | token = FMT_L; | |
443 | break; | |
444 | ||
445 | case 'A': | |
446 | token = FMT_A; | |
447 | break; | |
448 | ||
449 | case 'D': | |
99c72130 | 450 | c = next_char_not_space (); |
6f0f0b2e JD |
451 | if (c == 'P') |
452 | { | |
524af0d6 JB |
453 | if (!gfc_notify_std (GFC_STD_F2003, "DP format " |
454 | "specifier not allowed at %C")) | |
9cad01ce | 455 | return FMT_ERROR; |
6f0f0b2e JD |
456 | token = FMT_DP; |
457 | } | |
458 | else if (c == 'C') | |
459 | { | |
524af0d6 JB |
460 | if (!gfc_notify_std (GFC_STD_F2003, "DC format " |
461 | "specifier not allowed at %C")) | |
9cad01ce | 462 | return FMT_ERROR; |
6f0f0b2e JD |
463 | token = FMT_DC; |
464 | } | |
e73d3ca6 PT |
465 | else if (c == 'T') |
466 | { | |
467 | if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format " | |
468 | "specifier not allowed at %C")) | |
469 | return FMT_ERROR; | |
470 | token = FMT_DT; | |
99c72130 | 471 | c = next_char_not_space (); |
e73d3ca6 PT |
472 | if (c == '\'' || c == '"') |
473 | { | |
474 | delim = c; | |
475 | value = 0; | |
476 | ||
477 | for (;;) | |
478 | { | |
479 | c = next_char (INSTRING_WARN); | |
480 | if (c == '\0') | |
481 | { | |
482 | token = FMT_END; | |
483 | break; | |
484 | } | |
485 | ||
486 | if (c == delim) | |
487 | { | |
488 | c = next_char (NONSTRING); | |
e73d3ca6 PT |
489 | if (c == '\0') |
490 | { | |
491 | token = FMT_END; | |
492 | break; | |
493 | } | |
c7eb642e JD |
494 | if (c == '/') |
495 | { | |
496 | token = FMT_SLASH; | |
497 | break; | |
498 | } | |
5cdc4b0e JD |
499 | if (c == delim) |
500 | continue; | |
e73d3ca6 PT |
501 | unget_char (); |
502 | break; | |
503 | } | |
504 | } | |
505 | } | |
c7eb642e JD |
506 | else if (c == '/') |
507 | { | |
508 | token = FMT_SLASH; | |
509 | break; | |
510 | } | |
e73d3ca6 PT |
511 | else |
512 | unget_char (); | |
513 | } | |
6f0f0b2e JD |
514 | else |
515 | { | |
516 | token = FMT_D; | |
517 | unget_char (); | |
518 | } | |
6de9cd9a DN |
519 | break; |
520 | ||
f2a71504 | 521 | case 'R': |
99c72130 | 522 | c = next_char_not_space (); |
f2a71504 JD |
523 | switch (c) |
524 | { | |
525 | case 'C': | |
526 | token = FMT_RC; | |
527 | break; | |
528 | case 'D': | |
529 | token = FMT_RD; | |
530 | break; | |
531 | case 'N': | |
532 | token = FMT_RN; | |
533 | break; | |
534 | case 'P': | |
535 | token = FMT_RP; | |
536 | break; | |
537 | case 'U': | |
538 | token = FMT_RU; | |
539 | break; | |
540 | case 'Z': | |
541 | token = FMT_RZ; | |
542 | break; | |
543 | default: | |
544 | token = FMT_UNKNOWN; | |
545 | unget_char (); | |
546 | break; | |
547 | } | |
548 | break; | |
549 | ||
6de9cd9a DN |
550 | case '\0': |
551 | token = FMT_END; | |
552 | break; | |
553 | ||
b823d9eb JD |
554 | case '*': |
555 | token = FMT_STAR; | |
556 | break; | |
557 | ||
6de9cd9a DN |
558 | default: |
559 | token = FMT_UNKNOWN; | |
560 | break; | |
561 | } | |
562 | ||
563 | return token; | |
564 | } | |
565 | ||
566 | ||
de1ee8e1 JD |
567 | static const char * |
568 | token_to_string (format_token t) | |
569 | { | |
570 | switch (t) | |
571 | { | |
572 | case FMT_D: | |
573 | return "D"; | |
574 | case FMT_G: | |
575 | return "G"; | |
576 | case FMT_E: | |
577 | return "E"; | |
578 | case FMT_EN: | |
579 | return "EN"; | |
580 | case FMT_ES: | |
581 | return "ES"; | |
582 | default: | |
583 | return ""; | |
584 | } | |
585 | } | |
586 | ||
6de9cd9a DN |
587 | /* Check a format statement. The format string, either from a FORMAT |
588 | statement or a constant in an I/O statement has already been parsed | |
589 | by itself, and we are checking it for validity. The dual origin | |
590 | means that the warning message is a little less than great. */ | |
591 | ||
524af0d6 | 592 | static bool |
e444a887 | 593 | check_format (bool is_input) |
6de9cd9a | 594 | { |
0d0137a3 JJ |
595 | const char *posint_required |
596 | = G_("Positive width required in format string at %L"); | |
597 | const char *nonneg_required | |
598 | = G_("Nonnegative width required in format string at %L"); | |
599 | const char *unexpected_element | |
600 | = G_("Unexpected element %qc in format string at %L"); | |
601 | const char *unexpected_end | |
602 | = G_("Unexpected end of format string in format string at %L"); | |
603 | const char *zero_width | |
604 | = G_("Zero width in format descriptor in format string at %L"); | |
6de9cd9a | 605 | |
120a4c45 | 606 | const char *error = NULL; |
6de9cd9a DN |
607 | format_token t, u; |
608 | int level; | |
609 | int repeat; | |
524af0d6 | 610 | bool rv; |
6de9cd9a DN |
611 | |
612 | use_last_char = 0; | |
613 | saved_token = FMT_NONE; | |
614 | level = 0; | |
615 | repeat = 0; | |
524af0d6 | 616 | rv = true; |
c8129db1 | 617 | format_string_pos = 0; |
6de9cd9a DN |
618 | |
619 | t = format_lex (); | |
c2df0359 TB |
620 | if (t == FMT_ERROR) |
621 | goto fail; | |
6de9cd9a DN |
622 | if (t != FMT_LPAREN) |
623 | { | |
0d0137a3 | 624 | error = G_("Missing leading left parenthesis in format string at %L"); |
6de9cd9a DN |
625 | goto syntax; |
626 | } | |
627 | ||
628 | t = format_lex (); | |
c2df0359 TB |
629 | if (t == FMT_ERROR) |
630 | goto fail; | |
6de9cd9a DN |
631 | if (t == FMT_RPAREN) |
632 | goto finished; /* Empty format is legal */ | |
633 | saved_token = t; | |
634 | ||
635 | format_item: | |
636 | /* In this state, the next thing has to be a format item. */ | |
637 | t = format_lex (); | |
c2df0359 TB |
638 | if (t == FMT_ERROR) |
639 | goto fail; | |
53d8a8ac | 640 | format_item_1: |
6de9cd9a DN |
641 | switch (t) |
642 | { | |
b823d9eb JD |
643 | case FMT_STAR: |
644 | repeat = -1; | |
645 | t = format_lex (); | |
646 | if (t == FMT_ERROR) | |
647 | goto fail; | |
648 | if (t == FMT_LPAREN) | |
649 | { | |
650 | level++; | |
651 | goto format_item; | |
652 | } | |
0d0137a3 JJ |
653 | error = G_("Left parenthesis required after %<*%> in format string " |
654 | "at %L"); | |
b823d9eb JD |
655 | goto syntax; |
656 | ||
6de9cd9a DN |
657 | case FMT_POSINT: |
658 | repeat = value; | |
659 | t = format_lex (); | |
c2df0359 TB |
660 | if (t == FMT_ERROR) |
661 | goto fail; | |
6de9cd9a DN |
662 | if (t == FMT_LPAREN) |
663 | { | |
664 | level++; | |
665 | goto format_item; | |
666 | } | |
667 | ||
668 | if (t == FMT_SLASH) | |
669 | goto optional_comma; | |
670 | ||
671 | goto data_desc; | |
672 | ||
673 | case FMT_LPAREN: | |
674 | level++; | |
675 | goto format_item; | |
676 | ||
677 | case FMT_SIGNED_INT: | |
df5be068 | 678 | case FMT_ZERO: |
6de9cd9a DN |
679 | /* Signed integer can only precede a P format. */ |
680 | t = format_lex (); | |
c2df0359 TB |
681 | if (t == FMT_ERROR) |
682 | goto fail; | |
6de9cd9a DN |
683 | if (t != FMT_P) |
684 | { | |
0d0137a3 | 685 | error = G_("Expected P edit descriptor in format string at %L"); |
6de9cd9a DN |
686 | goto syntax; |
687 | } | |
688 | ||
689 | goto data_desc; | |
690 | ||
691 | case FMT_P: | |
8be123d4 | 692 | /* P requires a prior number. */ |
0d0137a3 JJ |
693 | error = G_("P descriptor requires leading scale factor in format " |
694 | "string at %L"); | |
6de9cd9a DN |
695 | goto syntax; |
696 | ||
697 | case FMT_X: | |
8be123d4 | 698 | /* X requires a prior number if we're being pedantic. */ |
3c6d5e12 JD |
699 | if (mode != MODE_FORMAT) |
700 | format_locus.nextc += format_string_pos; | |
524af0d6 JB |
701 | if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading " |
702 | "space count at %L", &format_locus)) | |
703 | return false; | |
e433aaee | 704 | goto between_desc; |
6de9cd9a DN |
705 | |
706 | case FMT_SIGN: | |
707 | case FMT_BLANK: | |
6f0f0b2e JD |
708 | case FMT_DP: |
709 | case FMT_DC: | |
f2a71504 JD |
710 | case FMT_RC: |
711 | case FMT_RD: | |
712 | case FMT_RN: | |
713 | case FMT_RP: | |
714 | case FMT_RU: | |
715 | case FMT_RZ: | |
6de9cd9a DN |
716 | goto between_desc; |
717 | ||
11670eeb RS |
718 | case FMT_CHAR: |
719 | goto extension_optional_comma; | |
720 | ||
6de9cd9a DN |
721 | case FMT_COLON: |
722 | case FMT_SLASH: | |
723 | goto optional_comma; | |
724 | ||
725 | case FMT_DOLLAR: | |
726 | t = format_lex (); | |
c2df0359 TB |
727 | if (t == FMT_ERROR) |
728 | goto fail; | |
c9330b03 | 729 | |
524af0d6 JB |
730 | if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus)) |
731 | return false; | |
6de9cd9a DN |
732 | if (t != FMT_RPAREN || level > 0) |
733 | { | |
db30e21c | 734 | gfc_warning (0, "$ should be the last specifier in format at %L", |
b823d9eb | 735 | &format_locus); |
7b666432 | 736 | goto optional_comma_1; |
6de9cd9a DN |
737 | } |
738 | ||
739 | goto finished; | |
740 | ||
74657812 JD |
741 | case FMT_T: |
742 | case FMT_TL: | |
743 | case FMT_TR: | |
6de9cd9a DN |
744 | case FMT_IBOZ: |
745 | case FMT_F: | |
746 | case FMT_E: | |
de1ee8e1 JD |
747 | case FMT_EN: |
748 | case FMT_ES: | |
6de9cd9a DN |
749 | case FMT_G: |
750 | case FMT_L: | |
751 | case FMT_A: | |
752 | case FMT_D: | |
6de9cd9a | 753 | case FMT_H: |
c7eb642e | 754 | case FMT_DT: |
6de9cd9a DN |
755 | goto data_desc; |
756 | ||
757 | case FMT_END: | |
758 | error = unexpected_end; | |
759 | goto syntax; | |
760 | ||
17f62b7e JM |
761 | case FMT_RPAREN: |
762 | if (flag_dec_blank_format_item) | |
763 | goto finished; | |
764 | else | |
765 | { | |
766 | error = G_("Missing item in format string at %L"); | |
767 | goto syntax; | |
768 | } | |
769 | ||
6de9cd9a DN |
770 | default: |
771 | error = unexpected_element; | |
772 | goto syntax; | |
773 | } | |
774 | ||
775 | data_desc: | |
776 | /* In this state, t must currently be a data descriptor. | |
777 | Deal with things that can/must follow the descriptor. */ | |
778 | switch (t) | |
779 | { | |
780 | case FMT_SIGN: | |
781 | case FMT_BLANK: | |
6f0f0b2e JD |
782 | case FMT_DP: |
783 | case FMT_DC: | |
6de9cd9a DN |
784 | case FMT_X: |
785 | break; | |
786 | ||
787 | case FMT_P: | |
3c6d5e12 | 788 | /* No comma after P allowed only for F, E, EN, ES, D, or G. |
e523d8bc JD |
789 | 10.1.1 (1). */ |
790 | t = format_lex (); | |
791 | if (t == FMT_ERROR) | |
792 | goto fail; | |
58fc89f6 | 793 | if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA |
e523d8bc | 794 | && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES |
c50d9687 | 795 | && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) |
e523d8bc | 796 | { |
0d0137a3 JJ |
797 | error = G_("Comma required after P descriptor in format string " |
798 | "at %L"); | |
e523d8bc JD |
799 | goto syntax; |
800 | } | |
801 | if (t != FMT_COMMA) | |
6de9cd9a | 802 | { |
6de9cd9a DN |
803 | if (t == FMT_POSINT) |
804 | { | |
e523d8bc JD |
805 | t = format_lex (); |
806 | if (t == FMT_ERROR) | |
807 | goto fail; | |
808 | } | |
0d0137a3 JJ |
809 | if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES |
810 | && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) | |
e523d8bc | 811 | { |
0d0137a3 JJ |
812 | error = G_("Comma required after P descriptor in format string " |
813 | "at %L"); | |
6de9cd9a DN |
814 | goto syntax; |
815 | } | |
6de9cd9a DN |
816 | } |
817 | ||
e523d8bc | 818 | saved_token = t; |
6de9cd9a DN |
819 | goto optional_comma; |
820 | ||
74657812 JD |
821 | case FMT_T: |
822 | case FMT_TL: | |
823 | case FMT_TR: | |
824 | t = format_lex (); | |
825 | if (t != FMT_POSINT) | |
826 | { | |
0d0137a3 JJ |
827 | error = G_("Positive width required with T descriptor in format " |
828 | "string at %L"); | |
74657812 JD |
829 | goto syntax; |
830 | } | |
831 | break; | |
832 | ||
6de9cd9a DN |
833 | case FMT_L: |
834 | t = format_lex (); | |
c2df0359 TB |
835 | if (t == FMT_ERROR) |
836 | goto fail; | |
6de9cd9a DN |
837 | if (t == FMT_POSINT) |
838 | break; | |
120a4c45 JD |
839 | if (mode != MODE_FORMAT) |
840 | format_locus.nextc += format_string_pos; | |
841 | if (t == FMT_ZERO) | |
842 | { | |
843 | switch (gfc_notification_std (GFC_STD_GNU)) | |
844 | { | |
845 | case WARNING: | |
846 | gfc_warning (0, "Extension: Zero width after L " | |
847 | "descriptor at %L", &format_locus); | |
848 | break; | |
849 | case ERROR: | |
850 | gfc_error ("Extension: Zero width after L " | |
851 | "descriptor at %L", &format_locus); | |
852 | goto fail; | |
853 | case SILENT: | |
854 | break; | |
855 | default: | |
856 | gcc_unreachable (); | |
857 | } | |
858 | } | |
859 | else | |
8f0d39a8 | 860 | { |
120a4c45 JD |
861 | saved_token = t; |
862 | gfc_notify_std (GFC_STD_GNU, "Missing positive width after " | |
863 | "L descriptor at %L", &format_locus); | |
8f0d39a8 FXC |
864 | } |
865 | break; | |
6de9cd9a DN |
866 | |
867 | case FMT_A: | |
868 | t = format_lex (); | |
c2df0359 TB |
869 | if (t == FMT_ERROR) |
870 | goto fail; | |
8955a005 JD |
871 | if (t == FMT_ZERO) |
872 | { | |
873 | error = zero_width; | |
874 | goto syntax; | |
875 | } | |
6de9cd9a DN |
876 | if (t != FMT_POSINT) |
877 | saved_token = t; | |
878 | break; | |
879 | ||
880 | case FMT_D: | |
881 | case FMT_E: | |
882 | case FMT_G: | |
de1ee8e1 JD |
883 | case FMT_EN: |
884 | case FMT_ES: | |
6de9cd9a | 885 | u = format_lex (); |
8955a005 JD |
886 | if (t == FMT_G && u == FMT_ZERO) |
887 | { | |
888 | if (is_input) | |
889 | { | |
890 | error = zero_width; | |
891 | goto syntax; | |
892 | } | |
a4d9b221 | 893 | if (!gfc_notify_std (GFC_STD_F2008, "%<G0%> in format at %L", |
524af0d6 JB |
894 | &format_locus)) |
895 | return false; | |
900e887f JD |
896 | u = format_lex (); |
897 | if (u != FMT_PERIOD) | |
898 | { | |
899 | saved_token = u; | |
900 | break; | |
901 | } | |
41d6f399 | 902 | u = format_lex (); |
900e887f | 903 | if (u != FMT_POSINT) |
41d6f399 | 904 | { |
900e887f | 905 | error = posint_required; |
41d6f399 JD |
906 | goto syntax; |
907 | } | |
c8129db1 JD |
908 | u = format_lex (); |
909 | if (u == FMT_E) | |
910 | { | |
0d0137a3 JJ |
911 | error = G_("E specifier not allowed with g0 descriptor in " |
912 | "format string at %L"); | |
c8129db1 JD |
913 | goto syntax; |
914 | } | |
915 | saved_token = u; | |
900e887f | 916 | break; |
6de9cd9a DN |
917 | } |
918 | ||
de1ee8e1 JD |
919 | if (u != FMT_POSINT) |
920 | { | |
67732fbc JD |
921 | if (flag_dec) |
922 | { | |
923 | if (flag_dec_format_defaults) | |
924 | { | |
925 | /* Assume a default width based on the variable size. */ | |
926 | saved_token = u; | |
927 | break; | |
928 | } | |
929 | else | |
930 | { | |
931 | gfc_error ("Positive width required in format " | |
932 | "specifier %s at %L", token_to_string (t), | |
933 | &format_locus); | |
934 | saved_token = u; | |
935 | goto fail; | |
936 | } | |
937 | } | |
938 | ||
939 | format_locus.nextc += format_string_pos; | |
940 | if (!gfc_notify_std (GFC_STD_F2018, | |
941 | "positive width required at %L", | |
942 | &format_locus)) | |
943 | { | |
944 | saved_token = u; | |
945 | goto fail; | |
946 | } | |
88a8126a JB |
947 | if (flag_dec_format_defaults) |
948 | { | |
949 | /* Assume a default width based on the variable size. */ | |
950 | saved_token = u; | |
951 | break; | |
952 | } | |
de1ee8e1 JD |
953 | } |
954 | ||
6de9cd9a | 955 | u = format_lex (); |
c2df0359 TB |
956 | if (u == FMT_ERROR) |
957 | goto fail; | |
6de9cd9a DN |
958 | if (u != FMT_PERIOD) |
959 | { | |
c9f4aa97 | 960 | /* Warn if -std=legacy, otherwise error. */ |
de1ee8e1 | 961 | format_locus.nextc += format_string_pos; |
c9f4aa97 | 962 | if (gfc_option.warn_std != 0) |
de1ee8e1 | 963 | { |
d0a2c5a9 | 964 | gfc_error ("Period required in format " |
de1ee8e1 JD |
965 | "specifier %s at %L", token_to_string (t), |
966 | &format_locus); | |
967 | saved_token = u; | |
d0a2c5a9 | 968 | goto fail; |
de1ee8e1 | 969 | } |
c9f4aa97 | 970 | else |
db30e21c | 971 | gfc_warning (0, "Period required in format " |
de1ee8e1 JD |
972 | "specifier %s at %L", token_to_string (t), |
973 | &format_locus); | |
c50d9687 JD |
974 | /* If we go to finished, we need to unwind this |
975 | before the next round. */ | |
976 | format_locus.nextc -= format_string_pos; | |
c9f4aa97 JD |
977 | saved_token = u; |
978 | break; | |
6de9cd9a DN |
979 | } |
980 | ||
981 | u = format_lex (); | |
c2df0359 TB |
982 | if (u == FMT_ERROR) |
983 | goto fail; | |
6de9cd9a DN |
984 | if (u != FMT_ZERO && u != FMT_POSINT) |
985 | { | |
986 | error = nonneg_required; | |
987 | goto syntax; | |
988 | } | |
989 | ||
990 | if (t == FMT_D) | |
991 | break; | |
992 | ||
993 | /* Look for optional exponent. */ | |
994 | u = format_lex (); | |
c2df0359 TB |
995 | if (u == FMT_ERROR) |
996 | goto fail; | |
6de9cd9a | 997 | if (u != FMT_E) |
0d0137a3 | 998 | saved_token = u; |
6de9cd9a DN |
999 | else |
1000 | { | |
1001 | u = format_lex (); | |
c2df0359 TB |
1002 | if (u == FMT_ERROR) |
1003 | goto fail; | |
6de9cd9a DN |
1004 | if (u != FMT_POSINT) |
1005 | { | |
68c28e37 JD |
1006 | if (u == FMT_ZERO) |
1007 | { | |
1008 | if (!gfc_notify_std (GFC_STD_F2018, | |
1009 | "Positive exponent width required in " | |
1010 | "format string at %L", &format_locus)) | |
1011 | { | |
1012 | saved_token = u; | |
1013 | goto fail; | |
1014 | } | |
1015 | } | |
1016 | else | |
1017 | { | |
1018 | error = G_("Positive exponent width required in format " | |
1019 | "string at %L"); | |
1020 | goto syntax; | |
1021 | } | |
6de9cd9a DN |
1022 | } |
1023 | } | |
1024 | ||
1025 | break; | |
1026 | ||
c7eb642e JD |
1027 | case FMT_DT: |
1028 | t = format_lex (); | |
1029 | if (t == FMT_ERROR) | |
1030 | goto fail; | |
1031 | switch (t) | |
1032 | { | |
1033 | case FMT_RPAREN: | |
1034 | level--; | |
1035 | if (level < 0) | |
1036 | goto finished; | |
1037 | goto between_desc; | |
1038 | ||
1039 | case FMT_COMMA: | |
1040 | goto format_item; | |
1041 | ||
26eacfe8 JD |
1042 | case FMT_COLON: |
1043 | goto format_item_1; | |
1044 | ||
c7eb642e JD |
1045 | case FMT_LPAREN: |
1046 | ||
1047 | dtio_vlist: | |
1048 | t = format_lex (); | |
1049 | if (t == FMT_ERROR) | |
1050 | goto fail; | |
1051 | ||
1052 | if (t != FMT_POSINT) | |
1053 | { | |
1054 | error = posint_required; | |
1055 | goto syntax; | |
1056 | } | |
1057 | ||
1058 | t = format_lex (); | |
1059 | if (t == FMT_ERROR) | |
1060 | goto fail; | |
1061 | ||
1062 | if (t == FMT_COMMA) | |
1063 | goto dtio_vlist; | |
1064 | if (t != FMT_RPAREN) | |
1065 | { | |
0d0137a3 JJ |
1066 | error = G_("Right parenthesis expected at %C in format string " |
1067 | "at %L"); | |
c7eb642e JD |
1068 | goto syntax; |
1069 | } | |
1070 | goto between_desc; | |
1071 | ||
1072 | default: | |
1073 | error = unexpected_element; | |
1074 | goto syntax; | |
1075 | } | |
1076 | break; | |
1077 | ||
6de9cd9a DN |
1078 | case FMT_F: |
1079 | t = format_lex (); | |
c2df0359 TB |
1080 | if (t == FMT_ERROR) |
1081 | goto fail; | |
6de9cd9a DN |
1082 | if (t != FMT_ZERO && t != FMT_POSINT) |
1083 | { | |
88a8126a JB |
1084 | if (flag_dec_format_defaults) |
1085 | { | |
1086 | /* Assume the default width is expected here and continue lexing. */ | |
1087 | value = 0; /* It doesn't matter what we set the value to here. */ | |
1088 | saved_token = t; | |
1089 | break; | |
1090 | } | |
6de9cd9a DN |
1091 | error = nonneg_required; |
1092 | goto syntax; | |
1093 | } | |
e444a887 TB |
1094 | else if (is_input && t == FMT_ZERO) |
1095 | { | |
1096 | error = posint_required; | |
1097 | goto syntax; | |
1098 | } | |
6de9cd9a DN |
1099 | |
1100 | t = format_lex (); | |
c2df0359 TB |
1101 | if (t == FMT_ERROR) |
1102 | goto fail; | |
6de9cd9a DN |
1103 | if (t != FMT_PERIOD) |
1104 | { | |
c9f4aa97 | 1105 | /* Warn if -std=legacy, otherwise error. */ |
b251af97 | 1106 | if (gfc_option.warn_std != 0) |
b823d9eb | 1107 | { |
0d0137a3 JJ |
1108 | error = G_("Period required in format specifier in format " |
1109 | "string at %L"); | |
b823d9eb JD |
1110 | goto syntax; |
1111 | } | |
e523d8bc JD |
1112 | if (mode != MODE_FORMAT) |
1113 | format_locus.nextc += format_string_pos; | |
db30e21c | 1114 | gfc_warning (0, "Period required in format specifier at %L", |
b823d9eb | 1115 | &format_locus); |
c9f4aa97 JD |
1116 | saved_token = t; |
1117 | break; | |
6de9cd9a DN |
1118 | } |
1119 | ||
1120 | t = format_lex (); | |
c2df0359 TB |
1121 | if (t == FMT_ERROR) |
1122 | goto fail; | |
6de9cd9a DN |
1123 | if (t != FMT_ZERO && t != FMT_POSINT) |
1124 | { | |
1125 | error = nonneg_required; | |
1126 | goto syntax; | |
1127 | } | |
1128 | ||
1129 | break; | |
1130 | ||
1131 | case FMT_H: | |
a383cfa3 | 1132 | if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) |
b823d9eb JD |
1133 | { |
1134 | if (mode != MODE_FORMAT) | |
1135 | format_locus.nextc += format_string_pos; | |
db30e21c | 1136 | gfc_warning (0, "The H format specifier at %L is" |
b823d9eb JD |
1137 | " a Fortran 95 deleted feature", &format_locus); |
1138 | } | |
171fc18d BD |
1139 | if (mode == MODE_STRING) |
1140 | { | |
1141 | format_string += value; | |
1142 | format_length -= value; | |
d0a2c5a9 | 1143 | format_string_pos += repeat; |
171fc18d BD |
1144 | } |
1145 | else | |
1146 | { | |
1147 | while (repeat >0) | |
1148 | { | |
696abb30 | 1149 | next_char (INSTRING_WARN); |
171fc18d BD |
1150 | repeat -- ; |
1151 | } | |
1152 | } | |
6de9cd9a DN |
1153 | break; |
1154 | ||
1155 | case FMT_IBOZ: | |
1156 | t = format_lex (); | |
c2df0359 TB |
1157 | if (t == FMT_ERROR) |
1158 | goto fail; | |
6de9cd9a DN |
1159 | if (t != FMT_ZERO && t != FMT_POSINT) |
1160 | { | |
88a8126a JB |
1161 | if (flag_dec_format_defaults) |
1162 | { | |
1163 | /* Assume the default width is expected here and continue lexing. */ | |
1164 | value = 0; /* It doesn't matter what we set the value to here. */ | |
1165 | saved_token = t; | |
1166 | } | |
1167 | else | |
1168 | { | |
1169 | error = nonneg_required; | |
1170 | goto syntax; | |
1171 | } | |
6de9cd9a | 1172 | } |
e444a887 TB |
1173 | else if (is_input && t == FMT_ZERO) |
1174 | { | |
1175 | error = posint_required; | |
1176 | goto syntax; | |
1177 | } | |
6de9cd9a DN |
1178 | |
1179 | t = format_lex (); | |
c2df0359 TB |
1180 | if (t == FMT_ERROR) |
1181 | goto fail; | |
6de9cd9a | 1182 | if (t != FMT_PERIOD) |
0d0137a3 | 1183 | saved_token = t; |
6de9cd9a DN |
1184 | else |
1185 | { | |
1186 | t = format_lex (); | |
c2df0359 TB |
1187 | if (t == FMT_ERROR) |
1188 | goto fail; | |
6de9cd9a DN |
1189 | if (t != FMT_ZERO && t != FMT_POSINT) |
1190 | { | |
1191 | error = nonneg_required; | |
1192 | goto syntax; | |
1193 | } | |
1194 | } | |
1195 | ||
1196 | break; | |
1197 | ||
1198 | default: | |
1199 | error = unexpected_element; | |
1200 | goto syntax; | |
1201 | } | |
1202 | ||
1203 | between_desc: | |
1204 | /* Between a descriptor and what comes next. */ | |
1205 | t = format_lex (); | |
c2df0359 TB |
1206 | if (t == FMT_ERROR) |
1207 | goto fail; | |
6de9cd9a DN |
1208 | switch (t) |
1209 | { | |
1210 | ||
1211 | case FMT_COMMA: | |
1212 | goto format_item; | |
1213 | ||
1214 | case FMT_RPAREN: | |
1215 | level--; | |
1216 | if (level < 0) | |
1217 | goto finished; | |
1218 | goto between_desc; | |
1219 | ||
1220 | case FMT_COLON: | |
1221 | case FMT_SLASH: | |
1222 | goto optional_comma; | |
1223 | ||
1224 | case FMT_END: | |
1225 | error = unexpected_end; | |
1226 | goto syntax; | |
1227 | ||
1228 | default: | |
b823d9eb | 1229 | if (mode != MODE_FORMAT) |
3c6d5e12 | 1230 | format_locus.nextc += format_string_pos - 1; |
524af0d6 JB |
1231 | if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) |
1232 | return false; | |
c50d9687 JD |
1233 | /* If we do not actually return a failure, we need to unwind this |
1234 | before the next round. */ | |
1235 | if (mode != MODE_FORMAT) | |
1236 | format_locus.nextc -= format_string_pos; | |
53d8a8ac | 1237 | goto format_item_1; |
6de9cd9a DN |
1238 | } |
1239 | ||
1240 | optional_comma: | |
1241 | /* Optional comma is a weird between state where we've just finished | |
7b666432 | 1242 | reading a colon, slash, dollar or P descriptor. */ |
6de9cd9a | 1243 | t = format_lex (); |
c2df0359 TB |
1244 | if (t == FMT_ERROR) |
1245 | goto fail; | |
7b666432 | 1246 | optional_comma_1: |
6de9cd9a DN |
1247 | switch (t) |
1248 | { | |
1249 | case FMT_COMMA: | |
1250 | break; | |
1251 | ||
1252 | case FMT_RPAREN: | |
1253 | level--; | |
1254 | if (level < 0) | |
1255 | goto finished; | |
1256 | goto between_desc; | |
1257 | ||
1258 | default: | |
1259 | /* Assume that we have another format item. */ | |
1260 | saved_token = t; | |
1261 | break; | |
1262 | } | |
1263 | ||
1264 | goto format_item; | |
1265 | ||
11670eeb RS |
1266 | extension_optional_comma: |
1267 | /* As a GNU extension, permit a missing comma after a string literal. */ | |
1268 | t = format_lex (); | |
c2df0359 TB |
1269 | if (t == FMT_ERROR) |
1270 | goto fail; | |
11670eeb RS |
1271 | switch (t) |
1272 | { | |
1273 | case FMT_COMMA: | |
1274 | break; | |
1275 | ||
1276 | case FMT_RPAREN: | |
1277 | level--; | |
1278 | if (level < 0) | |
1279 | goto finished; | |
1280 | goto between_desc; | |
1281 | ||
1282 | case FMT_COLON: | |
1283 | case FMT_SLASH: | |
1284 | goto optional_comma; | |
1285 | ||
1286 | case FMT_END: | |
1287 | error = unexpected_end; | |
1288 | goto syntax; | |
1289 | ||
1290 | default: | |
b823d9eb JD |
1291 | if (mode != MODE_FORMAT) |
1292 | format_locus.nextc += format_string_pos; | |
524af0d6 JB |
1293 | if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) |
1294 | return false; | |
c50d9687 JD |
1295 | /* If we do not actually return a failure, we need to unwind this |
1296 | before the next round. */ | |
1297 | if (mode != MODE_FORMAT) | |
1298 | format_locus.nextc -= format_string_pos; | |
11670eeb RS |
1299 | saved_token = t; |
1300 | break; | |
1301 | } | |
1302 | ||
1303 | goto format_item; | |
b823d9eb | 1304 | |
6de9cd9a | 1305 | syntax: |
c8129db1 JD |
1306 | if (mode != MODE_FORMAT) |
1307 | format_locus.nextc += format_string_pos; | |
9cad01ce DK |
1308 | if (error == unexpected_element) |
1309 | gfc_error (error, error_element, &format_locus); | |
1310 | else | |
0d0137a3 | 1311 | gfc_error (error, &format_locus); |
c2df0359 | 1312 | fail: |
524af0d6 | 1313 | rv = false; |
6de9cd9a DN |
1314 | |
1315 | finished: | |
1316 | return rv; | |
1317 | } | |
1318 | ||
1319 | ||
1320 | /* Given an expression node that is a constant string, see if it looks | |
1321 | like a format string. */ | |
1322 | ||
524af0d6 | 1323 | static bool |
e444a887 | 1324 | check_format_string (gfc_expr *e, bool is_input) |
6de9cd9a | 1325 | { |
524af0d6 | 1326 | bool rv; |
d0a2c5a9 | 1327 | int i; |
a48ebf39 | 1328 | if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) |
524af0d6 | 1329 | return true; |
86e9d05f | 1330 | |
6de9cd9a DN |
1331 | mode = MODE_STRING; |
1332 | format_string = e->value.character.string; | |
171fc18d | 1333 | |
9cad01ce DK |
1334 | /* More elaborate measures are needed to show where a problem is within a |
1335 | format string that has been calculated, but that's probably not worth the | |
1336 | effort. */ | |
1337 | format_locus = e->where; | |
d0a2c5a9 BD |
1338 | rv = check_format (is_input); |
1339 | /* check for extraneous characters at the end of an otherwise valid format | |
1340 | string, like '(A10,I3)F5' | |
1341 | start at the end and move back to the last character processed, | |
1342 | spaces are OK */ | |
524af0d6 | 1343 | if (rv && e->value.character.length > format_string_pos) |
d0a2c5a9 BD |
1344 | for (i=e->value.character.length-1;i>format_string_pos-1;i--) |
1345 | if (e->value.character.string[i] != ' ') | |
1346 | { | |
1347 | format_locus.nextc += format_length + 1; | |
db30e21c JM |
1348 | gfc_warning (0, |
1349 | "Extraneous characters in format at %L", &format_locus); | |
d0a2c5a9 BD |
1350 | break; |
1351 | } | |
1352 | return rv; | |
6de9cd9a DN |
1353 | } |
1354 | ||
1355 | ||
fd5cabb2 | 1356 | /************ Fortran I/O statement matchers *************/ |
6de9cd9a DN |
1357 | |
1358 | /* Match a FORMAT statement. This amounts to actually parsing the | |
1359 | format descriptors in order to correctly locate the end of the | |
1360 | format string. */ | |
1361 | ||
1362 | match | |
1363 | gfc_match_format (void) | |
1364 | { | |
1365 | gfc_expr *e; | |
1366 | locus start; | |
1367 | ||
e0e85e06 | 1368 | if (gfc_current_ns->proc_name |
b251af97 | 1369 | && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) |
e0e85e06 | 1370 | { |
e25a0da3 | 1371 | gfc_error ("Format statement in module main block at %C"); |
e0e85e06 PT |
1372 | return MATCH_ERROR; |
1373 | } | |
1374 | ||
5f0ba745 SK |
1375 | /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */ |
1376 | if ((gfc_current_state () == COMP_FUNCTION | |
1377 | || gfc_current_state () == COMP_SUBROUTINE) | |
1378 | && gfc_state_stack->previous->state == COMP_INTERFACE) | |
1379 | { | |
1380 | gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE"); | |
1381 | return MATCH_ERROR; | |
1382 | } | |
1383 | ||
6de9cd9a DN |
1384 | if (gfc_statement_label == NULL) |
1385 | { | |
1386 | gfc_error ("Missing format label at %C"); | |
1387 | return MATCH_ERROR; | |
1388 | } | |
1389 | gfc_gobble_whitespace (); | |
1390 | ||
1391 | mode = MODE_FORMAT; | |
1392 | format_length = 0; | |
1393 | ||
63645982 | 1394 | start = gfc_current_locus; |
6de9cd9a | 1395 | |
524af0d6 | 1396 | if (!check_format (false)) |
6de9cd9a DN |
1397 | return MATCH_ERROR; |
1398 | ||
1399 | if (gfc_match_eos () != MATCH_YES) | |
1400 | { | |
1401 | gfc_syntax_error (ST_FORMAT); | |
1402 | return MATCH_ERROR; | |
1403 | } | |
1404 | ||
1405 | /* The label doesn't get created until after the statement is done | |
1406 | being matched, so we have to leave the string for later. */ | |
1407 | ||
63645982 | 1408 | gfc_current_locus = start; /* Back to the beginning */ |
6de9cd9a DN |
1409 | |
1410 | new_st.loc = start; | |
1411 | new_st.op = EXEC_NOP; | |
1412 | ||
b7e75771 JD |
1413 | e = gfc_get_character_expr (gfc_default_character_kind, &start, |
1414 | NULL, format_length); | |
1415 | format_string = e->value.character.string; | |
6de9cd9a DN |
1416 | gfc_statement_label->format = e; |
1417 | ||
1418 | mode = MODE_COPY; | |
e444a887 | 1419 | check_format (false); /* Guaranteed to succeed */ |
6de9cd9a DN |
1420 | gfc_match_eos (); /* Guaranteed to succeed */ |
1421 | ||
1422 | return MATCH_YES; | |
1423 | } | |
1424 | ||
1425 | ||
1426 | /* Match an expression I/O tag of some sort. */ | |
1427 | ||
1428 | static match | |
b251af97 | 1429 | match_etag (const io_tag *tag, gfc_expr **v) |
6de9cd9a DN |
1430 | { |
1431 | gfc_expr *result; | |
1432 | match m; | |
1433 | ||
9b8d1901 | 1434 | m = gfc_match (tag->spec); |
6de9cd9a DN |
1435 | if (m != MATCH_YES) |
1436 | return m; | |
1437 | ||
9b8d1901 TS |
1438 | m = gfc_match (tag->value, &result); |
1439 | if (m != MATCH_YES) | |
1440 | { | |
1441 | gfc_error ("Invalid value for %s specification at %C", tag->name); | |
1442 | return MATCH_ERROR; | |
1443 | } | |
1444 | ||
6de9cd9a DN |
1445 | if (*v != NULL) |
1446 | { | |
1447 | gfc_error ("Duplicate %s specification at %C", tag->name); | |
1448 | gfc_free_expr (result); | |
1449 | return MATCH_ERROR; | |
1450 | } | |
1451 | ||
1452 | *v = result; | |
1453 | return MATCH_YES; | |
1454 | } | |
1455 | ||
1456 | ||
1457 | /* Match a variable I/O tag of some sort. */ | |
1458 | ||
1459 | static match | |
b251af97 | 1460 | match_vtag (const io_tag *tag, gfc_expr **v) |
6de9cd9a DN |
1461 | { |
1462 | gfc_expr *result; | |
1463 | match m; | |
1464 | ||
9b8d1901 | 1465 | m = gfc_match (tag->spec); |
6de9cd9a DN |
1466 | if (m != MATCH_YES) |
1467 | return m; | |
1468 | ||
9b8d1901 TS |
1469 | m = gfc_match (tag->value, &result); |
1470 | if (m != MATCH_YES) | |
1471 | { | |
1472 | gfc_error ("Invalid value for %s specification at %C", tag->name); | |
1473 | return MATCH_ERROR; | |
1474 | } | |
1475 | ||
6de9cd9a DN |
1476 | if (*v != NULL) |
1477 | { | |
1478 | gfc_error ("Duplicate %s specification at %C", tag->name); | |
1479 | gfc_free_expr (result); | |
1480 | return MATCH_ERROR; | |
1481 | } | |
1482 | ||
939e9f69 | 1483 | if (result->symtree) |
6de9cd9a | 1484 | { |
939e9f69 | 1485 | bool impure; |
6de9cd9a | 1486 | |
939e9f69 SK |
1487 | if (result->symtree->n.sym->attr.intent == INTENT_IN) |
1488 | { | |
1489 | gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name); | |
1490 | gfc_free_expr (result); | |
1491 | return MATCH_ERROR; | |
1492 | } | |
6de9cd9a | 1493 | |
939e9f69 SK |
1494 | impure = gfc_impure_variable (result->symtree->n.sym); |
1495 | if (impure && gfc_pure (NULL)) | |
1496 | { | |
1497 | gfc_error ("Variable %s cannot be assigned in PURE procedure at %C", | |
1498 | tag->name); | |
1499 | gfc_free_expr (result); | |
1500 | return MATCH_ERROR; | |
1501 | } | |
1502 | ||
1503 | if (impure) | |
1504 | gfc_unset_implicit_pure (NULL); | |
1505 | } | |
f1f39033 | 1506 | |
6de9cd9a DN |
1507 | *v = result; |
1508 | return MATCH_YES; | |
1509 | } | |
1510 | ||
1511 | ||
c9583ed2 TS |
1512 | /* Match I/O tags that cause variables to become redefined. */ |
1513 | ||
1514 | static match | |
3446fc50 | 1515 | match_out_tag (const io_tag *tag, gfc_expr **result) |
c9583ed2 TS |
1516 | { |
1517 | match m; | |
1518 | ||
3446fc50 | 1519 | m = match_vtag (tag, result); |
c9583ed2 | 1520 | if (m == MATCH_YES) |
939e9f69 SK |
1521 | { |
1522 | if ((*result)->symtree) | |
1523 | gfc_check_do_variable ((*result)->symtree); | |
1524 | ||
1525 | if ((*result)->expr_type == EXPR_CONSTANT) | |
1526 | { | |
1527 | gfc_error ("Expecting a variable at %L", &(*result)->where); | |
1528 | return MATCH_ERROR; | |
1529 | } | |
1530 | } | |
c9583ed2 TS |
1531 | |
1532 | return m; | |
1533 | } | |
1534 | ||
1535 | ||
6de9cd9a DN |
1536 | /* Match a label I/O tag. */ |
1537 | ||
1538 | static match | |
b251af97 | 1539 | match_ltag (const io_tag *tag, gfc_st_label ** label) |
6de9cd9a DN |
1540 | { |
1541 | match m; | |
1542 | gfc_st_label *old; | |
1543 | ||
1544 | old = *label; | |
9b8d1901 TS |
1545 | m = gfc_match (tag->spec); |
1546 | if (m != MATCH_YES) | |
1547 | return m; | |
1548 | ||
1549 | m = gfc_match (tag->value, label); | |
1550 | if (m != MATCH_YES) | |
1551 | { | |
1552 | gfc_error ("Invalid value for %s specification at %C", tag->name); | |
1553 | return MATCH_ERROR; | |
1554 | } | |
1555 | ||
1556 | if (old) | |
6de9cd9a DN |
1557 | { |
1558 | gfc_error ("Duplicate %s label specification at %C", tag->name); | |
1559 | return MATCH_ERROR; | |
1560 | } | |
1561 | ||
524af0d6 | 1562 | if (!gfc_reference_st_label (*label, ST_LABEL_TARGET)) |
89031799 TS |
1563 | return MATCH_ERROR; |
1564 | ||
6de9cd9a DN |
1565 | return m; |
1566 | } | |
1567 | ||
1568 | ||
0ef33d44 FR |
1569 | /* Match a tag using match_etag, but only if -fdec is enabled. */ |
1570 | static match | |
1571 | match_dec_etag (const io_tag *tag, gfc_expr **e) | |
1572 | { | |
1573 | match m = match_etag (tag, e); | |
1574 | if (flag_dec && m != MATCH_NO) | |
1575 | return m; | |
1576 | else if (m != MATCH_NO) | |
1577 | { | |
cf004230 FR |
1578 | gfc_error ("%s at %C is a DEC extension, enable with " |
1579 | "%<-fdec%>", tag->name); | |
0ef33d44 FR |
1580 | return MATCH_ERROR; |
1581 | } | |
1582 | return m; | |
1583 | } | |
1584 | ||
1585 | ||
1586 | /* Match a tag using match_vtag, but only if -fdec is enabled. */ | |
1587 | static match | |
1588 | match_dec_vtag (const io_tag *tag, gfc_expr **e) | |
1589 | { | |
1590 | match m = match_vtag(tag, e); | |
1591 | if (flag_dec && m != MATCH_NO) | |
1592 | return m; | |
1593 | else if (m != MATCH_NO) | |
1594 | { | |
cf004230 FR |
1595 | gfc_error ("%s at %C is a DEC extension, enable with " |
1596 | "%<-fdec%>", tag->name); | |
0ef33d44 FR |
1597 | return MATCH_ERROR; |
1598 | } | |
1599 | return m; | |
1600 | } | |
1601 | ||
1602 | ||
1603 | /* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */ | |
1604 | ||
1605 | static match | |
1606 | match_dec_ftag (const io_tag *tag, gfc_open *o) | |
1607 | { | |
1608 | match m; | |
1609 | ||
1610 | m = gfc_match (tag->spec); | |
1611 | if (m != MATCH_YES) | |
1612 | return m; | |
1613 | ||
1614 | if (!flag_dec) | |
1615 | { | |
cf004230 FR |
1616 | gfc_error ("%s at %C is a DEC extension, enable with " |
1617 | "%<-fdec%>", tag->name); | |
0ef33d44 FR |
1618 | return MATCH_ERROR; |
1619 | } | |
1620 | ||
1621 | /* Just set the READONLY flag, which we use at runtime to avoid delete on | |
1622 | close. */ | |
1623 | if (tag == &tag_readonly) | |
1624 | { | |
1625 | o->readonly |= 1; | |
1626 | return MATCH_YES; | |
1627 | } | |
1628 | ||
1629 | /* Interpret SHARED as SHARE='DENYNONE' (read lock). */ | |
1630 | else if (tag == &tag_shared) | |
1631 | { | |
1632 | if (o->share != NULL) | |
1633 | { | |
1634 | gfc_error ("Duplicate %s specification at %C", tag->name); | |
1635 | return MATCH_ERROR; | |
1636 | } | |
1637 | o->share = gfc_get_character_expr (gfc_default_character_kind, | |
1638 | &gfc_current_locus, "denynone", 8); | |
1639 | return MATCH_YES; | |
1640 | } | |
1641 | ||
1642 | /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */ | |
1643 | else if (tag == &tag_noshared) | |
1644 | { | |
1645 | if (o->share != NULL) | |
1646 | { | |
1647 | gfc_error ("Duplicate %s specification at %C", tag->name); | |
1648 | return MATCH_ERROR; | |
1649 | } | |
1650 | o->share = gfc_get_character_expr (gfc_default_character_kind, | |
1651 | &gfc_current_locus, "denyrw", 6); | |
1652 | return MATCH_YES; | |
1653 | } | |
1654 | ||
1655 | /* We handle all DEC tags above. */ | |
1656 | gcc_unreachable (); | |
1657 | } | |
1658 | ||
1659 | ||
f25bf34f | 1660 | /* Resolution of the FORMAT tag, to be called from resolve_tag. */ |
6de9cd9a | 1661 | |
524af0d6 | 1662 | static bool |
a48718a2 | 1663 | resolve_tag_format (gfc_expr *e) |
6de9cd9a | 1664 | { |
f25bf34f TS |
1665 | if (e->expr_type == EXPR_CONSTANT |
1666 | && (e->ts.type != BT_CHARACTER | |
1667 | || e->ts.kind != gfc_default_character_kind)) | |
6de9cd9a | 1668 | { |
f25bf34f TS |
1669 | gfc_error ("Constant expression in FORMAT tag at %L must be " |
1670 | "of type default CHARACTER", &e->where); | |
524af0d6 | 1671 | return false; |
6de9cd9a DN |
1672 | } |
1673 | ||
a48718a2 TK |
1674 | /* Concatenate a constant character array into a single character |
1675 | expression. */ | |
1676 | ||
1677 | if ((e->expr_type == EXPR_ARRAY || e->rank > 0) | |
1678 | && e->ts.type == BT_CHARACTER | |
1679 | && gfc_is_constant_expr (e)) | |
1680 | { | |
1681 | if (e->expr_type == EXPR_VARIABLE | |
1682 | && e->symtree->n.sym->attr.flavor == FL_PARAMETER) | |
1683 | gfc_simplify_expr (e, 1); | |
1684 | ||
1685 | if (e->expr_type == EXPR_ARRAY) | |
1686 | { | |
1687 | gfc_constructor *c; | |
1688 | gfc_charlen_t n, len; | |
1689 | gfc_expr *r; | |
1690 | gfc_char_t *dest, *src; | |
1691 | ||
0652a151 SK |
1692 | if (e->value.constructor == NULL) |
1693 | { | |
44facdb7 FR |
1694 | gfc_error ("FORMAT tag at %L cannot be a zero-sized array", |
1695 | &e->where); | |
0652a151 SK |
1696 | return false; |
1697 | } | |
1698 | ||
a48718a2 TK |
1699 | n = 0; |
1700 | c = gfc_constructor_first (e->value.constructor); | |
1701 | len = c->expr->value.character.length; | |
1702 | ||
1703 | for ( ; c; c = gfc_constructor_next (c)) | |
1704 | n += len; | |
1705 | ||
1706 | r = gfc_get_character_expr (e->ts.kind, &e->where, NULL, n); | |
1707 | dest = r->value.character.string; | |
1708 | ||
1709 | for (c = gfc_constructor_first (e->value.constructor); | |
1710 | c; c = gfc_constructor_next (c)) | |
1711 | { | |
1712 | src = c->expr->value.character.string; | |
1713 | for (gfc_charlen_t i = 0 ; i < len; i++) | |
1714 | *dest++ = *src++; | |
1715 | } | |
1716 | ||
1717 | gfc_replace_expr (e, r); | |
1718 | return true; | |
1719 | } | |
1720 | } | |
1721 | ||
f25bf34f TS |
1722 | /* If e's rank is zero and e is not an element of an array, it should be |
1723 | of integer or character type. The integer variable should be | |
1724 | ASSIGNED. */ | |
7e279142 JJ |
1725 | if (e->rank == 0 |
1726 | && (e->expr_type != EXPR_VARIABLE | |
1727 | || e->symtree == NULL | |
1728 | || e->symtree->n.sym->as == NULL | |
1729 | || e->symtree->n.sym->as->rank == 0)) | |
6de9cd9a | 1730 | { |
75933b07 TB |
1731 | if ((e->ts.type != BT_CHARACTER |
1732 | || e->ts.kind != gfc_default_character_kind) | |
1733 | && e->ts.type != BT_INTEGER) | |
7fd4d312 | 1734 | { |
75933b07 TB |
1735 | gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER " |
1736 | "or of INTEGER", &e->where); | |
524af0d6 | 1737 | return false; |
7fd4d312 | 1738 | } |
f25bf34f | 1739 | else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) |
6de9cd9a | 1740 | { |
524af0d6 JB |
1741 | if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in " |
1742 | "FORMAT tag at %L", &e->where)) | |
1743 | return false; | |
f25bf34f | 1744 | if (e->symtree->n.sym->attr.assign != 1) |
ba661c8b | 1745 | { |
a4d9b221 | 1746 | gfc_error ("Variable %qs at %L has not been assigned a " |
f25bf34f | 1747 | "format label", e->symtree->n.sym->name, &e->where); |
524af0d6 | 1748 | return false; |
ba661c8b | 1749 | } |
6de9cd9a | 1750 | } |
f25bf34f | 1751 | else if (e->ts.type == BT_INTEGER) |
ce2df7c6 | 1752 | { |
a4d9b221 | 1753 | gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED " |
f25bf34f | 1754 | "variable", gfc_basic_typename (e->ts.type), &e->where); |
524af0d6 | 1755 | return false; |
ce2df7c6 | 1756 | } |
f25bf34f | 1757 | |
524af0d6 | 1758 | return true; |
f25bf34f TS |
1759 | } |
1760 | ||
7e279142 JJ |
1761 | /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY. |
1762 | It may be assigned an Hollerith constant. */ | |
1763 | if (e->ts.type != BT_CHARACTER) | |
6de9cd9a | 1764 | { |
524af0d6 JB |
1765 | if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag " |
1766 | "at %L", &e->where)) | |
1767 | return false; | |
7e279142 JJ |
1768 | |
1769 | if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) | |
1770 | { | |
1771 | gfc_error ("Non-character assumed shape array element in FORMAT" | |
1772 | " tag at %L", &e->where); | |
524af0d6 | 1773 | return false; |
7e279142 JJ |
1774 | } |
1775 | ||
1776 | if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) | |
1777 | { | |
1778 | gfc_error ("Non-character assumed size array element in FORMAT" | |
1779 | " tag at %L", &e->where); | |
524af0d6 | 1780 | return false; |
7e279142 JJ |
1781 | } |
1782 | ||
1783 | if (e->rank == 0 && e->symtree->n.sym->attr.pointer) | |
1784 | { | |
1785 | gfc_error ("Non-character pointer array element in FORMAT tag at %L", | |
1786 | &e->where); | |
524af0d6 | 1787 | return false; |
7e279142 | 1788 | } |
f25bf34f | 1789 | } |
418a78fa | 1790 | |
524af0d6 | 1791 | return true; |
f25bf34f | 1792 | } |
418a78fa | 1793 | |
e0e85e06 | 1794 | |
f25bf34f | 1795 | /* Do expression resolution and type-checking on an expression tag. */ |
418a78fa | 1796 | |
524af0d6 | 1797 | static bool |
f25bf34f TS |
1798 | resolve_tag (const io_tag *tag, gfc_expr *e) |
1799 | { | |
1800 | if (e == NULL) | |
524af0d6 | 1801 | return true; |
f25bf34f | 1802 | |
524af0d6 JB |
1803 | if (!gfc_resolve_expr (e)) |
1804 | return false; | |
f25bf34f TS |
1805 | |
1806 | if (tag == &tag_format) | |
1807 | return resolve_tag_format (e); | |
1808 | ||
1809 | if (e->ts.type != tag->type) | |
1810 | { | |
1811 | gfc_error ("%s tag at %L must be of type %s", tag->name, | |
1812 | &e->where, gfc_basic_typename (tag->type)); | |
524af0d6 | 1813 | return false; |
6de9cd9a DN |
1814 | } |
1815 | ||
75933b07 TB |
1816 | if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind) |
1817 | { | |
1818 | gfc_error ("%s tag at %L must be a character string of default kind", | |
1819 | tag->name, &e->where); | |
524af0d6 | 1820 | return false; |
75933b07 TB |
1821 | } |
1822 | ||
f25bf34f TS |
1823 | if (e->rank != 0) |
1824 | { | |
1825 | gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); | |
524af0d6 | 1826 | return false; |
f25bf34f TS |
1827 | } |
1828 | ||
1829 | if (tag == &tag_iomsg) | |
1830 | { | |
524af0d6 JB |
1831 | if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where)) |
1832 | return false; | |
f25bf34f TS |
1833 | } |
1834 | ||
72b572cb FXC |
1835 | if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength |
1836 | || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl) | |
f25bf34f TS |
1837 | && e->ts.kind != gfc_default_integer_kind) |
1838 | { | |
524af0d6 JB |
1839 | if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " |
1840 | "INTEGER in %s tag at %L", tag->name, &e->where)) | |
1841 | return false; | |
f25bf34f TS |
1842 | } |
1843 | ||
72b572cb FXC |
1844 | if (e->ts.kind != gfc_default_logical_kind && |
1845 | (tag == &tag_exist || tag == &tag_named || tag == &tag_opened | |
1846 | || tag == &tag_pending)) | |
92336ae1 | 1847 | { |
72b572cb | 1848 | if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind " |
524af0d6 JB |
1849 | "in %s tag at %L", tag->name, &e->where)) |
1850 | return false; | |
92336ae1 SK |
1851 | } |
1852 | ||
8e8dc060 DK |
1853 | if (tag == &tag_newunit) |
1854 | { | |
524af0d6 JB |
1855 | if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L", |
1856 | &e->where)) | |
1857 | return false; | |
8e8dc060 DK |
1858 | } |
1859 | ||
1860 | /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */ | |
1861 | if (tag == &tag_newunit || tag == &tag_iostat | |
1862 | || tag == &tag_size || tag == &tag_iomsg) | |
1863 | { | |
1864 | char context[64]; | |
1865 | ||
1866 | sprintf (context, _("%s tag"), tag->name); | |
524af0d6 JB |
1867 | if (!gfc_check_vardef_context (e, false, false, false, context)) |
1868 | return false; | |
8e8dc060 DK |
1869 | } |
1870 | ||
f25bf34f TS |
1871 | if (tag == &tag_convert) |
1872 | { | |
524af0d6 JB |
1873 | if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where)) |
1874 | return false; | |
f25bf34f | 1875 | } |
8e8dc060 | 1876 | |
524af0d6 | 1877 | return true; |
6de9cd9a DN |
1878 | } |
1879 | ||
1880 | ||
1881 | /* Match a single tag of an OPEN statement. */ | |
1882 | ||
1883 | static match | |
b251af97 | 1884 | match_open_element (gfc_open *open) |
6de9cd9a DN |
1885 | { |
1886 | match m; | |
1887 | ||
d06b3496 | 1888 | m = match_etag (&tag_e_async, &open->asynchronous); |
6f0f0b2e JD |
1889 | if (m != MATCH_NO) |
1890 | return m; | |
6de9cd9a | 1891 | m = match_etag (&tag_unit, &open->unit); |
7aba8abe TK |
1892 | if (m != MATCH_NO) |
1893 | return m; | |
fd5cabb2 | 1894 | m = match_etag (&tag_iomsg, &open->iomsg); |
6de9cd9a DN |
1895 | if (m != MATCH_NO) |
1896 | return m; | |
c9583ed2 | 1897 | m = match_out_tag (&tag_iostat, &open->iostat); |
6de9cd9a DN |
1898 | if (m != MATCH_NO) |
1899 | return m; | |
1900 | m = match_etag (&tag_file, &open->file); | |
1901 | if (m != MATCH_NO) | |
1902 | return m; | |
1903 | m = match_etag (&tag_status, &open->status); | |
1904 | if (m != MATCH_NO) | |
1905 | return m; | |
1906 | m = match_etag (&tag_e_access, &open->access); | |
1907 | if (m != MATCH_NO) | |
1908 | return m; | |
1909 | m = match_etag (&tag_e_form, &open->form); | |
1910 | if (m != MATCH_NO) | |
1911 | return m; | |
1912 | m = match_etag (&tag_e_recl, &open->recl); | |
1913 | if (m != MATCH_NO) | |
1914 | return m; | |
1915 | m = match_etag (&tag_e_blank, &open->blank); | |
1916 | if (m != MATCH_NO) | |
1917 | return m; | |
1918 | m = match_etag (&tag_e_position, &open->position); | |
1919 | if (m != MATCH_NO) | |
1920 | return m; | |
1921 | m = match_etag (&tag_e_action, &open->action); | |
1922 | if (m != MATCH_NO) | |
1923 | return m; | |
1924 | m = match_etag (&tag_e_delim, &open->delim); | |
1925 | if (m != MATCH_NO) | |
1926 | return m; | |
1927 | m = match_etag (&tag_e_pad, &open->pad); | |
6f0f0b2e JD |
1928 | if (m != MATCH_NO) |
1929 | return m; | |
1930 | m = match_etag (&tag_e_decimal, &open->decimal); | |
1931 | if (m != MATCH_NO) | |
1932 | return m; | |
1933 | m = match_etag (&tag_e_encoding, &open->encoding); | |
1934 | if (m != MATCH_NO) | |
1935 | return m; | |
1936 | m = match_etag (&tag_e_round, &open->round); | |
1937 | if (m != MATCH_NO) | |
1938 | return m; | |
1939 | m = match_etag (&tag_e_sign, &open->sign); | |
6de9cd9a DN |
1940 | if (m != MATCH_NO) |
1941 | return m; | |
1942 | m = match_ltag (&tag_err, &open->err); | |
181c9f4a TK |
1943 | if (m != MATCH_NO) |
1944 | return m; | |
1945 | m = match_etag (&tag_convert, &open->convert); | |
9ad55c33 JD |
1946 | if (m != MATCH_NO) |
1947 | return m; | |
1948 | m = match_out_tag (&tag_newunit, &open->newunit); | |
6de9cd9a DN |
1949 | if (m != MATCH_NO) |
1950 | return m; | |
1951 | ||
0ef33d44 FR |
1952 | /* The following are extensions enabled with -fdec. */ |
1953 | m = match_dec_etag (&tag_e_share, &open->share); | |
1954 | if (m != MATCH_NO) | |
1955 | return m; | |
1956 | m = match_dec_etag (&tag_cc, &open->cc); | |
1957 | if (m != MATCH_NO) | |
1958 | return m; | |
1959 | m = match_dec_ftag (&tag_readonly, open); | |
1960 | if (m != MATCH_NO) | |
1961 | return m; | |
1962 | m = match_dec_ftag (&tag_shared, open); | |
1963 | if (m != MATCH_NO) | |
1964 | return m; | |
1965 | m = match_dec_ftag (&tag_noshared, open); | |
1966 | if (m != MATCH_NO) | |
1967 | return m; | |
1968 | ||
6de9cd9a DN |
1969 | return MATCH_NO; |
1970 | } | |
1971 | ||
1972 | ||
1973 | /* Free the gfc_open structure and all the expressions it contains. */ | |
1974 | ||
1975 | void | |
b251af97 | 1976 | gfc_free_open (gfc_open *open) |
6de9cd9a | 1977 | { |
6de9cd9a DN |
1978 | if (open == NULL) |
1979 | return; | |
1980 | ||
1981 | gfc_free_expr (open->unit); | |
7aba8abe | 1982 | gfc_free_expr (open->iomsg); |
6de9cd9a DN |
1983 | gfc_free_expr (open->iostat); |
1984 | gfc_free_expr (open->file); | |
1985 | gfc_free_expr (open->status); | |
1986 | gfc_free_expr (open->access); | |
1987 | gfc_free_expr (open->form); | |
1988 | gfc_free_expr (open->recl); | |
1989 | gfc_free_expr (open->blank); | |
1990 | gfc_free_expr (open->position); | |
1991 | gfc_free_expr (open->action); | |
1992 | gfc_free_expr (open->delim); | |
1993 | gfc_free_expr (open->pad); | |
6f0f0b2e JD |
1994 | gfc_free_expr (open->decimal); |
1995 | gfc_free_expr (open->encoding); | |
1996 | gfc_free_expr (open->round); | |
1997 | gfc_free_expr (open->sign); | |
181c9f4a | 1998 | gfc_free_expr (open->convert); |
6f0f0b2e | 1999 | gfc_free_expr (open->asynchronous); |
9ad55c33 | 2000 | gfc_free_expr (open->newunit); |
0ef33d44 FR |
2001 | gfc_free_expr (open->share); |
2002 | gfc_free_expr (open->cc); | |
cede9502 | 2003 | free (open); |
6de9cd9a DN |
2004 | } |
2005 | ||
2006 | ||
44facdb7 FR |
2007 | static int |
2008 | compare_to_allowed_values (const char *specifier, const char *allowed[], | |
2009 | const char *allowed_f2003[], | |
2010 | const char *allowed_gnu[], gfc_char_t *value, | |
2011 | const char *statement, bool warn, locus *where, | |
2012 | int *num = NULL); | |
2013 | ||
2014 | ||
2015 | static bool | |
2016 | check_open_constraints (gfc_open *open, locus *where); | |
2017 | ||
6de9cd9a DN |
2018 | /* Resolve everything in a gfc_open structure. */ |
2019 | ||
524af0d6 | 2020 | bool |
44facdb7 | 2021 | gfc_resolve_open (gfc_open *open, locus *where) |
6de9cd9a | 2022 | { |
6de9cd9a | 2023 | RESOLVE_TAG (&tag_unit, open->unit); |
7aba8abe | 2024 | RESOLVE_TAG (&tag_iomsg, open->iomsg); |
6de9cd9a DN |
2025 | RESOLVE_TAG (&tag_iostat, open->iostat); |
2026 | RESOLVE_TAG (&tag_file, open->file); | |
2027 | RESOLVE_TAG (&tag_status, open->status); | |
1e90e92f | 2028 | RESOLVE_TAG (&tag_e_access, open->access); |
6de9cd9a DN |
2029 | RESOLVE_TAG (&tag_e_form, open->form); |
2030 | RESOLVE_TAG (&tag_e_recl, open->recl); | |
6de9cd9a DN |
2031 | RESOLVE_TAG (&tag_e_blank, open->blank); |
2032 | RESOLVE_TAG (&tag_e_position, open->position); | |
2033 | RESOLVE_TAG (&tag_e_action, open->action); | |
2034 | RESOLVE_TAG (&tag_e_delim, open->delim); | |
2035 | RESOLVE_TAG (&tag_e_pad, open->pad); | |
6f0f0b2e JD |
2036 | RESOLVE_TAG (&tag_e_decimal, open->decimal); |
2037 | RESOLVE_TAG (&tag_e_encoding, open->encoding); | |
d06b3496 | 2038 | RESOLVE_TAG (&tag_e_async, open->asynchronous); |
6f0f0b2e JD |
2039 | RESOLVE_TAG (&tag_e_round, open->round); |
2040 | RESOLVE_TAG (&tag_e_sign, open->sign); | |
181c9f4a | 2041 | RESOLVE_TAG (&tag_convert, open->convert); |
9ad55c33 | 2042 | RESOLVE_TAG (&tag_newunit, open->newunit); |
0ef33d44 FR |
2043 | RESOLVE_TAG (&tag_e_share, open->share); |
2044 | RESOLVE_TAG (&tag_cc, open->cc); | |
6de9cd9a | 2045 | |
524af0d6 JB |
2046 | if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) |
2047 | return false; | |
6de9cd9a | 2048 | |
44facdb7 | 2049 | return check_open_constraints (open, where); |
6de9cd9a DN |
2050 | } |
2051 | ||
2052 | ||
16dbbd99 FXC |
2053 | /* Check if a given value for a SPECIFIER is either in the list of values |
2054 | allowed in F95 or F2003, issuing an error message and returning a zero | |
2055 | value if it is not allowed. */ | |
b251af97 | 2056 | |
a4792d44 TK |
2057 | |
2058 | static int | |
2059 | compare_to_allowed_values (const char *specifier, const char *allowed[], | |
44facdb7 | 2060 | const char *allowed_f2003[], |
a4792d44 | 2061 | const char *allowed_gnu[], gfc_char_t *value, |
44facdb7 FR |
2062 | const char *statement, bool warn, locus *where, |
2063 | int *num) | |
16dbbd99 FXC |
2064 | { |
2065 | int i; | |
2066 | unsigned int len; | |
2067 | ||
00660189 | 2068 | len = gfc_wide_strlen (value); |
16dbbd99 FXC |
2069 | if (len > 0) |
2070 | { | |
2071 | for (len--; len > 0; len--) | |
2072 | if (value[len] != ' ') | |
2073 | break; | |
2074 | len++; | |
2075 | } | |
2076 | ||
2077 | for (i = 0; allowed[i]; i++) | |
b251af97 | 2078 | if (len == strlen (allowed[i]) |
00660189 | 2079 | && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) |
a4792d44 TK |
2080 | { |
2081 | if (num) | |
2082 | *num = i; | |
16dbbd99 | 2083 | return 1; |
a4792d44 | 2084 | } |
16dbbd99 | 2085 | |
44facdb7 FR |
2086 | if (!where) |
2087 | where = &gfc_current_locus; | |
2088 | ||
16dbbd99 | 2089 | for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) |
b251af97 | 2090 | if (len == strlen (allowed_f2003[i]) |
00660189 FXC |
2091 | && gfc_wide_strncasecmp (value, allowed_f2003[i], |
2092 | strlen (allowed_f2003[i])) == 0) | |
16dbbd99 FXC |
2093 | { |
2094 | notification n = gfc_notification_std (GFC_STD_F2003); | |
2095 | ||
2096 | if (n == WARNING || (warn && n == ERROR)) | |
2097 | { | |
44facdb7 FR |
2098 | gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L " |
2099 | "has value %qs", specifier, statement, where, | |
16dbbd99 FXC |
2100 | allowed_f2003[i]); |
2101 | return 1; | |
2102 | } | |
2103 | else | |
2104 | if (n == ERROR) | |
2105 | { | |
9717f7a1 | 2106 | gfc_notify_std (GFC_STD_F2003, "%s specifier in " |
44facdb7 FR |
2107 | "%s statement at %L has value %qs", specifier, |
2108 | statement, where, allowed_f2003[i]); | |
16dbbd99 FXC |
2109 | return 0; |
2110 | } | |
2111 | ||
2112 | /* n == SILENT */ | |
2113 | return 1; | |
2114 | } | |
2115 | ||
2116 | for (i = 0; allowed_gnu && allowed_gnu[i]; i++) | |
b251af97 | 2117 | if (len == strlen (allowed_gnu[i]) |
00660189 FXC |
2118 | && gfc_wide_strncasecmp (value, allowed_gnu[i], |
2119 | strlen (allowed_gnu[i])) == 0) | |
16dbbd99 FXC |
2120 | { |
2121 | notification n = gfc_notification_std (GFC_STD_GNU); | |
2122 | ||
2123 | if (n == WARNING || (warn && n == ERROR)) | |
2124 | { | |
44facdb7 FR |
2125 | gfc_warning (0, "Extension: %s specifier in %s statement at %L " |
2126 | "has value %qs", specifier, statement, where, | |
16dbbd99 FXC |
2127 | allowed_gnu[i]); |
2128 | return 1; | |
2129 | } | |
2130 | else | |
2131 | if (n == ERROR) | |
2132 | { | |
9717f7a1 | 2133 | gfc_notify_std (GFC_STD_GNU, "%s specifier in " |
44facdb7 FR |
2134 | "%s statement at %L has value %qs", specifier, |
2135 | statement, where, allowed_gnu[i]); | |
16dbbd99 FXC |
2136 | return 0; |
2137 | } | |
2138 | ||
2139 | /* n == SILENT */ | |
2140 | return 1; | |
2141 | } | |
2142 | ||
2143 | if (warn) | |
2144 | { | |
00660189 | 2145 | char *s = gfc_widechar_to_char (value, -1); |
db30e21c | 2146 | gfc_warning (0, |
44facdb7 FR |
2147 | "%s specifier in %s statement at %L has invalid value %qs", |
2148 | specifier, statement, where, s); | |
cede9502 | 2149 | free (s); |
16dbbd99 FXC |
2150 | return 1; |
2151 | } | |
2152 | else | |
2153 | { | |
00660189 | 2154 | char *s = gfc_widechar_to_char (value, -1); |
44facdb7 FR |
2155 | gfc_error ("%s specifier in %s statement at %L has invalid value %qs", |
2156 | specifier, statement, where, s); | |
cede9502 | 2157 | free (s); |
16dbbd99 FXC |
2158 | return 0; |
2159 | } | |
2160 | } | |
2161 | ||
b251af97 | 2162 | |
44facdb7 FR |
2163 | /* Check constraints on the OPEN statement. |
2164 | Similar to check_io_constraints for data transfer statements. | |
2165 | At this point all tags have already been resolved via resolve_tag, which, | |
2166 | among other things, verifies that BT_CHARACTER tags are of default kind. */ | |
6de9cd9a | 2167 | |
44facdb7 FR |
2168 | static bool |
2169 | check_open_constraints (gfc_open *open, locus *where) | |
6de9cd9a | 2170 | { |
44facdb7 FR |
2171 | #define warn_or_error(...) \ |
2172 | { \ | |
2173 | if (warn) \ | |
2174 | gfc_warning (0, __VA_ARGS__); \ | |
2175 | else \ | |
2176 | { \ | |
2177 | gfc_error (__VA_ARGS__); \ | |
2178 | return false; \ | |
2179 | } \ | |
2180 | } | |
f1f39033 | 2181 | |
44facdb7 | 2182 | bool warn = (open->err || open->iostat) ? true : false; |
9ad55c33 | 2183 | |
16dbbd99 FXC |
2184 | /* Checks on the ACCESS specifier. */ |
2185 | if (open->access && open->access->expr_type == EXPR_CONSTANT) | |
2186 | { | |
b251af97 SK |
2187 | static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL }; |
2188 | static const char *access_f2003[] = { "STREAM", NULL }; | |
2189 | static const char *access_gnu[] = { "APPEND", NULL }; | |
16dbbd99 FXC |
2190 | |
2191 | if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, | |
2192 | access_gnu, | |
2193 | open->access->value.character.string, | |
44facdb7 FR |
2194 | "OPEN", warn, &open->access->where)) |
2195 | return false; | |
16dbbd99 FXC |
2196 | } |
2197 | ||
2198 | /* Checks on the ACTION specifier. */ | |
2199 | if (open->action && open->action->expr_type == EXPR_CONSTANT) | |
2200 | { | |
0ef33d44 | 2201 | gfc_char_t *str = open->action->value.character.string; |
b251af97 | 2202 | static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; |
16dbbd99 FXC |
2203 | |
2204 | if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, | |
44facdb7 FR |
2205 | str, "OPEN", warn, &open->action->where)) |
2206 | return false; | |
0ef33d44 FR |
2207 | |
2208 | /* With READONLY, only allow ACTION='READ'. */ | |
2209 | if (open->readonly && (gfc_wide_strlen (str) != 4 | |
2210 | || gfc_wide_strncasecmp (str, "READ", 4) != 0)) | |
2211 | { | |
44facdb7 FR |
2212 | gfc_error ("ACTION type conflicts with READONLY specifier at %L", |
2213 | &open->action->where); | |
2214 | return false; | |
0ef33d44 FR |
2215 | } |
2216 | } | |
44facdb7 | 2217 | |
0ef33d44 FR |
2218 | /* If we see READONLY and no ACTION, set ACTION='READ'. */ |
2219 | else if (open->readonly && open->action == NULL) | |
2220 | { | |
2221 | open->action = gfc_get_character_expr (gfc_default_character_kind, | |
2222 | &gfc_current_locus, "read", 4); | |
16dbbd99 FXC |
2223 | } |
2224 | ||
2225 | /* Checks on the ASYNCHRONOUS specifier. */ | |
6f0f0b2e | 2226 | if (open->asynchronous) |
16dbbd99 | 2227 | { |
44facdb7 FR |
2228 | if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L " |
2229 | "not allowed in Fortran 95", | |
2230 | &open->asynchronous->where)) | |
2231 | return false; | |
87550b74 | 2232 | |
6f0f0b2e JD |
2233 | if (open->asynchronous->expr_type == EXPR_CONSTANT) |
2234 | { | |
2235 | static const char * asynchronous[] = { "YES", "NO", NULL }; | |
2236 | ||
2237 | if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, | |
2238 | NULL, NULL, open->asynchronous->value.character.string, | |
44facdb7 FR |
2239 | "OPEN", warn, &open->asynchronous->where)) |
2240 | return false; | |
6f0f0b2e JD |
2241 | } |
2242 | } | |
2243 | ||
16dbbd99 | 2244 | /* Checks on the BLANK specifier. */ |
6f0f0b2e | 2245 | if (open->blank) |
16dbbd99 | 2246 | { |
44facdb7 FR |
2247 | if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " |
2248 | "not allowed in Fortran 95", &open->blank->where)) | |
2249 | return false; | |
2e431643 | 2250 | |
6f0f0b2e JD |
2251 | if (open->blank->expr_type == EXPR_CONSTANT) |
2252 | { | |
2253 | static const char *blank[] = { "ZERO", "NULL", NULL }; | |
2254 | ||
2255 | if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, | |
2256 | open->blank->value.character.string, | |
44facdb7 FR |
2257 | "OPEN", warn, &open->blank->where)) |
2258 | return false; | |
6f0f0b2e | 2259 | } |
16dbbd99 FXC |
2260 | } |
2261 | ||
0ef33d44 | 2262 | /* Checks on the CARRIAGECONTROL specifier. */ |
44facdb7 | 2263 | if (open->cc && open->cc->expr_type == EXPR_CONSTANT) |
0ef33d44 | 2264 | { |
44facdb7 FR |
2265 | static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; |
2266 | if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, | |
2267 | open->cc->value.character.string, | |
2268 | "OPEN", warn, &open->cc->where)) | |
2269 | return false; | |
0ef33d44 FR |
2270 | } |
2271 | ||
16dbbd99 | 2272 | /* Checks on the DECIMAL specifier. */ |
6f0f0b2e | 2273 | if (open->decimal) |
16dbbd99 | 2274 | { |
44facdb7 FR |
2275 | if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " |
2276 | "not allowed in Fortran 95", &open->decimal->where)) | |
2277 | return false; | |
2e431643 | 2278 | |
6f0f0b2e JD |
2279 | if (open->decimal->expr_type == EXPR_CONSTANT) |
2280 | { | |
2281 | static const char * decimal[] = { "COMMA", "POINT", NULL }; | |
2282 | ||
2283 | if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, | |
2284 | open->decimal->value.character.string, | |
44facdb7 FR |
2285 | "OPEN", warn, &open->decimal->where)) |
2286 | return false; | |
6f0f0b2e JD |
2287 | } |
2288 | } | |
16dbbd99 FXC |
2289 | |
2290 | /* Checks on the DELIM specifier. */ | |
6f0f0b2e | 2291 | if (open->delim) |
16dbbd99 | 2292 | { |
6f0f0b2e JD |
2293 | if (open->delim->expr_type == EXPR_CONSTANT) |
2294 | { | |
2295 | static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; | |
2296 | ||
2297 | if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, | |
2298 | open->delim->value.character.string, | |
44facdb7 FR |
2299 | "OPEN", warn, &open->delim->where)) |
2300 | return false; | |
6f0f0b2e | 2301 | } |
16dbbd99 FXC |
2302 | } |
2303 | ||
2304 | /* Checks on the ENCODING specifier. */ | |
6f0f0b2e | 2305 | if (open->encoding) |
16dbbd99 | 2306 | { |
44facdb7 FR |
2307 | if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L " |
2308 | "not allowed in Fortran 95", &open->encoding->where)) | |
2309 | return false; | |
2e431643 | 2310 | |
6f0f0b2e JD |
2311 | if (open->encoding->expr_type == EXPR_CONSTANT) |
2312 | { | |
dad80a1b | 2313 | static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; |
16dbbd99 | 2314 | |
6f0f0b2e JD |
2315 | if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, |
2316 | open->encoding->value.character.string, | |
44facdb7 FR |
2317 | "OPEN", warn, &open->encoding->where)) |
2318 | return false; | |
6f0f0b2e JD |
2319 | } |
2320 | } | |
16dbbd99 FXC |
2321 | |
2322 | /* Checks on the FORM specifier. */ | |
2323 | if (open->form && open->form->expr_type == EXPR_CONSTANT) | |
2324 | { | |
b251af97 | 2325 | static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; |
16dbbd99 FXC |
2326 | |
2327 | if (!compare_to_allowed_values ("FORM", form, NULL, NULL, | |
2328 | open->form->value.character.string, | |
44facdb7 FR |
2329 | "OPEN", warn, &open->form->where)) |
2330 | return false; | |
16dbbd99 FXC |
2331 | } |
2332 | ||
2333 | /* Checks on the PAD specifier. */ | |
2334 | if (open->pad && open->pad->expr_type == EXPR_CONSTANT) | |
2335 | { | |
b251af97 | 2336 | static const char *pad[] = { "YES", "NO", NULL }; |
16dbbd99 FXC |
2337 | |
2338 | if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, | |
2339 | open->pad->value.character.string, | |
44facdb7 FR |
2340 | "OPEN", warn, &open->pad->where)) |
2341 | return false; | |
16dbbd99 FXC |
2342 | } |
2343 | ||
2344 | /* Checks on the POSITION specifier. */ | |
2345 | if (open->position && open->position->expr_type == EXPR_CONSTANT) | |
2346 | { | |
b251af97 | 2347 | static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; |
16dbbd99 FXC |
2348 | |
2349 | if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, | |
2350 | open->position->value.character.string, | |
44facdb7 FR |
2351 | "OPEN", warn, &open->position->where)) |
2352 | return false; | |
16dbbd99 FXC |
2353 | } |
2354 | ||
2355 | /* Checks on the ROUND specifier. */ | |
6f0f0b2e | 2356 | if (open->round) |
16dbbd99 | 2357 | { |
44facdb7 FR |
2358 | if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " |
2359 | "not allowed in Fortran 95", &open->round->where)) | |
2360 | return false; | |
2e431643 | 2361 | |
6f0f0b2e JD |
2362 | if (open->round->expr_type == EXPR_CONSTANT) |
2363 | { | |
2364 | static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", | |
2365 | "COMPATIBLE", "PROCESSOR_DEFINED", | |
2366 | NULL }; | |
2367 | ||
2368 | if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, | |
2369 | open->round->value.character.string, | |
44facdb7 FR |
2370 | "OPEN", warn, &open->round->where)) |
2371 | return false; | |
6f0f0b2e JD |
2372 | } |
2373 | } | |
16dbbd99 | 2374 | |
0ef33d44 | 2375 | /* Checks on the SHARE specifier. */ |
44facdb7 | 2376 | if (open->share && open->share->expr_type == EXPR_CONSTANT) |
0ef33d44 | 2377 | { |
44facdb7 FR |
2378 | static const char *share[] = { "DENYNONE", "DENYRW", NULL }; |
2379 | if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, | |
2380 | open->share->value.character.string, | |
2381 | "OPEN", warn, &open->share->where)) | |
2382 | return false; | |
0ef33d44 FR |
2383 | } |
2384 | ||
16dbbd99 | 2385 | /* Checks on the SIGN specifier. */ |
44facdb7 | 2386 | if (open->sign) |
16dbbd99 | 2387 | { |
44facdb7 FR |
2388 | if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " |
2389 | "not allowed in Fortran 95", &open->sign->where)) | |
2390 | return false; | |
2e431643 | 2391 | |
6f0f0b2e JD |
2392 | if (open->sign->expr_type == EXPR_CONSTANT) |
2393 | { | |
2394 | static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", | |
2395 | NULL }; | |
2396 | ||
2397 | if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, | |
2398 | open->sign->value.character.string, | |
44facdb7 FR |
2399 | "OPEN", warn, &open->sign->where)) |
2400 | return false; | |
6f0f0b2e JD |
2401 | } |
2402 | } | |
16dbbd99 | 2403 | |
16dbbd99 FXC |
2404 | /* Checks on the RECL specifier. */ |
2405 | if (open->recl && open->recl->expr_type == EXPR_CONSTANT | |
2406 | && open->recl->ts.type == BT_INTEGER | |
2407 | && mpz_sgn (open->recl->value.integer) != 1) | |
2408 | { | |
44facdb7 FR |
2409 | warn_or_error ("RECL in OPEN statement at %L must be positive", |
2410 | &open->recl->where); | |
16dbbd99 FXC |
2411 | } |
2412 | ||
2413 | /* Checks on the STATUS specifier. */ | |
2414 | if (open->status && open->status->expr_type == EXPR_CONSTANT) | |
2415 | { | |
b251af97 | 2416 | static const char *status[] = { "OLD", "NEW", "SCRATCH", |
16dbbd99 FXC |
2417 | "REPLACE", "UNKNOWN", NULL }; |
2418 | ||
2419 | if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, | |
2420 | open->status->value.character.string, | |
44facdb7 FR |
2421 | "OPEN", warn, &open->status->where)) |
2422 | return false; | |
16dbbd99 | 2423 | |
d06b3496 JD |
2424 | /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, |
2425 | the FILE= specifier shall appear. */ | |
b251af97 | 2426 | if (open->file == NULL |
00660189 FXC |
2427 | && (gfc_wide_strncasecmp (open->status->value.character.string, |
2428 | "replace", 7) == 0 | |
2429 | || gfc_wide_strncasecmp (open->status->value.character.string, | |
2430 | "new", 3) == 0)) | |
16dbbd99 | 2431 | { |
00660189 FXC |
2432 | char *s = gfc_widechar_to_char (open->status->value.character.string, |
2433 | -1); | |
44facdb7 FR |
2434 | warn_or_error ("The STATUS specified in OPEN statement at %L is " |
2435 | "%qs and no FILE specifier is present", | |
2436 | &open->status->where, s); | |
cede9502 | 2437 | free (s); |
16dbbd99 FXC |
2438 | } |
2439 | ||
d06b3496 JD |
2440 | /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, |
2441 | the FILE= specifier shall not appear. */ | |
00660189 FXC |
2442 | if (gfc_wide_strncasecmp (open->status->value.character.string, |
2443 | "scratch", 7) == 0 && open->file) | |
16dbbd99 | 2444 | { |
44facdb7 | 2445 | warn_or_error ("The STATUS specified in OPEN statement at %L " |
b251af97 | 2446 | "cannot have the value SCRATCH if a FILE specifier " |
44facdb7 | 2447 | "is present", &open->status->where); |
16dbbd99 FXC |
2448 | } |
2449 | } | |
2450 | ||
72eb8e78 SK |
2451 | /* Checks on NEWUNIT specifier. */ |
2452 | if (open->newunit) | |
2453 | { | |
2454 | if (open->unit) | |
2455 | { | |
44facdb7 FR |
2456 | gfc_error ("UNIT specifier not allowed with NEWUNIT at %L", |
2457 | &open->newunit->where); | |
2458 | return false; | |
72eb8e78 SK |
2459 | } |
2460 | ||
56bf85c1 HA |
2461 | if (!open->file && |
2462 | (!open->status || | |
2463 | (open->status->expr_type == EXPR_CONSTANT | |
72eb8e78 | 2464 | && gfc_wide_strncasecmp (open->status->value.character.string, |
56bf85c1 HA |
2465 | "scratch", 7) != 0))) |
2466 | { | |
72eb8e78 | 2467 | gfc_error ("NEWUNIT specifier must have FILE= " |
44facdb7 FR |
2468 | "or STATUS='scratch' at %L", &open->newunit->where); |
2469 | return false; | |
72eb8e78 SK |
2470 | } |
2471 | } | |
2472 | else if (!open->unit) | |
2473 | { | |
44facdb7 FR |
2474 | gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified", |
2475 | where); | |
2476 | return false; | |
72eb8e78 SK |
2477 | } |
2478 | ||
16dbbd99 FXC |
2479 | /* Things that are not allowed for unformatted I/O. */ |
2480 | if (open->form && open->form->expr_type == EXPR_CONSTANT | |
6f0f0b2e JD |
2481 | && (open->delim || open->decimal || open->encoding || open->round |
2482 | || open->sign || open->pad || open->blank) | |
00660189 FXC |
2483 | && gfc_wide_strncasecmp (open->form->value.character.string, |
2484 | "unformatted", 11) == 0) | |
16dbbd99 | 2485 | { |
44facdb7 FR |
2486 | locus *loc; |
2487 | const char *spec; | |
2488 | if (open->delim) | |
2489 | { | |
2490 | loc = &open->delim->where; | |
2491 | spec = "DELIM "; | |
2492 | } | |
2493 | else if (open->pad) | |
2494 | { | |
2495 | loc = &open->pad->where; | |
2496 | spec = "PAD "; | |
2497 | } | |
2498 | else if (open->blank) | |
2499 | { | |
2500 | loc = &open->blank->where; | |
2501 | spec = "BLANK "; | |
2502 | } | |
2503 | else | |
2504 | { | |
2505 | loc = where; | |
2506 | spec = ""; | |
2507 | } | |
16dbbd99 | 2508 | |
44facdb7 FR |
2509 | warn_or_error ("%s specifier at %L not allowed in OPEN statement for " |
2510 | "unformatted I/O", spec, loc); | |
16dbbd99 FXC |
2511 | } |
2512 | ||
2513 | if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT | |
00660189 FXC |
2514 | && gfc_wide_strncasecmp (open->access->value.character.string, |
2515 | "stream", 6) == 0) | |
16dbbd99 | 2516 | { |
44facdb7 FR |
2517 | warn_or_error ("RECL specifier not allowed in OPEN statement at %L for " |
2518 | "stream I/O", &open->recl->where); | |
16dbbd99 FXC |
2519 | } |
2520 | ||
b251af97 SK |
2521 | if (open->position |
2522 | && open->access && open->access->expr_type == EXPR_CONSTANT | |
00660189 FXC |
2523 | && !(gfc_wide_strncasecmp (open->access->value.character.string, |
2524 | "sequential", 10) == 0 | |
2525 | || gfc_wide_strncasecmp (open->access->value.character.string, | |
2526 | "stream", 6) == 0 | |
2527 | || gfc_wide_strncasecmp (open->access->value.character.string, | |
2528 | "append", 6) == 0)) | |
16dbbd99 | 2529 | { |
44facdb7 FR |
2530 | warn_or_error ("POSITION specifier in OPEN statement at %L only allowed " |
2531 | "for stream or sequential ACCESS", &open->position->where); | |
16dbbd99 FXC |
2532 | } |
2533 | ||
44facdb7 | 2534 | return true; |
16dbbd99 | 2535 | #undef warn_or_error |
44facdb7 FR |
2536 | } |
2537 | ||
2538 | ||
2539 | /* Match an OPEN statement. */ | |
2540 | ||
2541 | match | |
2542 | gfc_match_open (void) | |
2543 | { | |
2544 | gfc_open *open; | |
2545 | match m; | |
2546 | ||
2547 | m = gfc_match_char ('('); | |
2548 | if (m == MATCH_NO) | |
2549 | return m; | |
2550 | ||
2551 | open = XCNEW (gfc_open); | |
2552 | ||
2553 | m = match_open_element (open); | |
2554 | ||
2555 | if (m == MATCH_ERROR) | |
2556 | goto cleanup; | |
2557 | if (m == MATCH_NO) | |
2558 | { | |
2559 | m = gfc_match_expr (&open->unit); | |
2560 | if (m == MATCH_ERROR) | |
2561 | goto cleanup; | |
2562 | } | |
2563 | ||
2564 | for (;;) | |
2565 | { | |
2566 | if (gfc_match_char (')') == MATCH_YES) | |
2567 | break; | |
2568 | if (gfc_match_char (',') != MATCH_YES) | |
2569 | goto syntax; | |
2570 | ||
2571 | m = match_open_element (open); | |
2572 | if (m == MATCH_ERROR) | |
2573 | goto cleanup; | |
2574 | if (m == MATCH_NO) | |
2575 | goto syntax; | |
2576 | } | |
2577 | ||
2578 | if (gfc_match_eos () == MATCH_NO) | |
2579 | goto syntax; | |
2580 | ||
2581 | if (gfc_pure (NULL)) | |
2582 | { | |
2583 | gfc_error ("OPEN statement not allowed in PURE procedure at %C"); | |
2584 | goto cleanup; | |
2585 | } | |
2586 | ||
2587 | gfc_unset_implicit_pure (NULL); | |
16dbbd99 | 2588 | |
6de9cd9a DN |
2589 | new_st.op = EXEC_OPEN; |
2590 | new_st.ext.open = open; | |
2591 | return MATCH_YES; | |
2592 | ||
2593 | syntax: | |
2594 | gfc_syntax_error (ST_OPEN); | |
2595 | ||
2596 | cleanup: | |
2597 | gfc_free_open (open); | |
2598 | return MATCH_ERROR; | |
2599 | } | |
2600 | ||
2601 | ||
2602 | /* Free a gfc_close structure an all its expressions. */ | |
2603 | ||
2604 | void | |
b251af97 | 2605 | gfc_free_close (gfc_close *close) |
6de9cd9a | 2606 | { |
6de9cd9a DN |
2607 | if (close == NULL) |
2608 | return; | |
2609 | ||
2610 | gfc_free_expr (close->unit); | |
7aba8abe | 2611 | gfc_free_expr (close->iomsg); |
6de9cd9a DN |
2612 | gfc_free_expr (close->iostat); |
2613 | gfc_free_expr (close->status); | |
cede9502 | 2614 | free (close); |
6de9cd9a DN |
2615 | } |
2616 | ||
2617 | ||
e7dc5b4f | 2618 | /* Match elements of a CLOSE statement. */ |
6de9cd9a DN |
2619 | |
2620 | static match | |
b251af97 | 2621 | match_close_element (gfc_close *close) |
6de9cd9a DN |
2622 | { |
2623 | match m; | |
2624 | ||
2625 | m = match_etag (&tag_unit, &close->unit); | |
2626 | if (m != MATCH_NO) | |
2627 | return m; | |
2628 | m = match_etag (&tag_status, &close->status); | |
7aba8abe TK |
2629 | if (m != MATCH_NO) |
2630 | return m; | |
fd5cabb2 | 2631 | m = match_etag (&tag_iomsg, &close->iomsg); |
6de9cd9a DN |
2632 | if (m != MATCH_NO) |
2633 | return m; | |
c9583ed2 | 2634 | m = match_out_tag (&tag_iostat, &close->iostat); |
6de9cd9a DN |
2635 | if (m != MATCH_NO) |
2636 | return m; | |
2637 | m = match_ltag (&tag_err, &close->err); | |
2638 | if (m != MATCH_NO) | |
2639 | return m; | |
2640 | ||
2641 | return MATCH_NO; | |
2642 | } | |
2643 | ||
2644 | ||
2645 | /* Match a CLOSE statement. */ | |
2646 | ||
2647 | match | |
2648 | gfc_match_close (void) | |
2649 | { | |
2650 | gfc_close *close; | |
2651 | match m; | |
2652 | ||
2653 | m = gfc_match_char ('('); | |
2654 | if (m == MATCH_NO) | |
2655 | return m; | |
2656 | ||
ece3f663 | 2657 | close = XCNEW (gfc_close); |
6de9cd9a DN |
2658 | |
2659 | m = match_close_element (close); | |
2660 | ||
2661 | if (m == MATCH_ERROR) | |
2662 | goto cleanup; | |
2663 | if (m == MATCH_NO) | |
2664 | { | |
2665 | m = gfc_match_expr (&close->unit); | |
2666 | if (m == MATCH_NO) | |
2667 | goto syntax; | |
2668 | if (m == MATCH_ERROR) | |
2669 | goto cleanup; | |
2670 | } | |
2671 | ||
2672 | for (;;) | |
2673 | { | |
2674 | if (gfc_match_char (')') == MATCH_YES) | |
2675 | break; | |
2676 | if (gfc_match_char (',') != MATCH_YES) | |
2677 | goto syntax; | |
2678 | ||
2679 | m = match_close_element (close); | |
2680 | if (m == MATCH_ERROR) | |
2681 | goto cleanup; | |
2682 | if (m == MATCH_NO) | |
2683 | goto syntax; | |
2684 | } | |
2685 | ||
2686 | if (gfc_match_eos () == MATCH_NO) | |
2687 | goto syntax; | |
2688 | ||
2689 | if (gfc_pure (NULL)) | |
2690 | { | |
2691 | gfc_error ("CLOSE statement not allowed in PURE procedure at %C"); | |
2692 | goto cleanup; | |
2693 | } | |
2694 | ||
ccd7751b | 2695 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 2696 | |
6de9cd9a DN |
2697 | new_st.op = EXEC_CLOSE; |
2698 | new_st.ext.close = close; | |
2699 | return MATCH_YES; | |
2700 | ||
2701 | syntax: | |
2702 | gfc_syntax_error (ST_CLOSE); | |
2703 | ||
2704 | cleanup: | |
2705 | gfc_free_close (close); | |
2706 | return MATCH_ERROR; | |
2707 | } | |
2708 | ||
2709 | ||
44facdb7 FR |
2710 | static bool |
2711 | check_close_constraints (gfc_close *close, locus *where) | |
6de9cd9a | 2712 | { |
44facdb7 | 2713 | bool warn = (close->iostat || close->err) ? true : false; |
6de9cd9a | 2714 | |
b35f6a97 FXC |
2715 | if (close->unit == NULL) |
2716 | { | |
44facdb7 | 2717 | gfc_error ("CLOSE statement at %L requires a UNIT number", where); |
524af0d6 | 2718 | return false; |
b35f6a97 FXC |
2719 | } |
2720 | ||
9ad55c33 JD |
2721 | if (close->unit->expr_type == EXPR_CONSTANT |
2722 | && close->unit->ts.type == BT_INTEGER | |
2723 | && mpz_sgn (close->unit->value.integer) < 0) | |
2724 | { | |
2725 | gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", | |
2726 | &close->unit->where); | |
2727 | } | |
2728 | ||
44facdb7 FR |
2729 | /* Checks on the STATUS specifier. */ |
2730 | if (close->status && close->status->expr_type == EXPR_CONSTANT) | |
2731 | { | |
2732 | static const char *status[] = { "KEEP", "DELETE", NULL }; | |
2733 | ||
2734 | if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, | |
2735 | close->status->value.character.string, | |
2736 | "CLOSE", warn, &close->status->where)) | |
2737 | return false; | |
2738 | } | |
2739 | ||
524af0d6 | 2740 | return true; |
6de9cd9a DN |
2741 | } |
2742 | ||
44facdb7 FR |
2743 | /* Resolve everything in a gfc_close structure. */ |
2744 | ||
2745 | bool | |
2746 | gfc_resolve_close (gfc_close *close, locus *where) | |
2747 | { | |
2748 | RESOLVE_TAG (&tag_unit, close->unit); | |
2749 | RESOLVE_TAG (&tag_iomsg, close->iomsg); | |
2750 | RESOLVE_TAG (&tag_iostat, close->iostat); | |
2751 | RESOLVE_TAG (&tag_status, close->status); | |
2752 | ||
2753 | if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) | |
2754 | return false; | |
2755 | ||
2756 | return check_close_constraints (close, where); | |
2757 | } | |
2758 | ||
6de9cd9a DN |
2759 | |
2760 | /* Free a gfc_filepos structure. */ | |
2761 | ||
2762 | void | |
b251af97 | 2763 | gfc_free_filepos (gfc_filepos *fp) |
6de9cd9a | 2764 | { |
6de9cd9a | 2765 | gfc_free_expr (fp->unit); |
7aba8abe | 2766 | gfc_free_expr (fp->iomsg); |
6de9cd9a | 2767 | gfc_free_expr (fp->iostat); |
cede9502 | 2768 | free (fp); |
6de9cd9a DN |
2769 | } |
2770 | ||
2771 | ||
6403ec5f | 2772 | /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */ |
6de9cd9a DN |
2773 | |
2774 | static match | |
b251af97 | 2775 | match_file_element (gfc_filepos *fp) |
6de9cd9a DN |
2776 | { |
2777 | match m; | |
2778 | ||
2779 | m = match_etag (&tag_unit, &fp->unit); | |
7aba8abe TK |
2780 | if (m != MATCH_NO) |
2781 | return m; | |
fd5cabb2 | 2782 | m = match_etag (&tag_iomsg, &fp->iomsg); |
6de9cd9a DN |
2783 | if (m != MATCH_NO) |
2784 | return m; | |
c9583ed2 | 2785 | m = match_out_tag (&tag_iostat, &fp->iostat); |
6de9cd9a DN |
2786 | if (m != MATCH_NO) |
2787 | return m; | |
2788 | m = match_ltag (&tag_err, &fp->err); | |
2789 | if (m != MATCH_NO) | |
2790 | return m; | |
2791 | ||
2792 | return MATCH_NO; | |
2793 | } | |
2794 | ||
2795 | ||
2796 | /* Match the second half of the file-positioning statements, REWIND, | |
6403ec5f | 2797 | BACKSPACE, ENDFILE, or the FLUSH statement. */ |
6de9cd9a DN |
2798 | |
2799 | static match | |
2800 | match_filepos (gfc_statement st, gfc_exec_op op) | |
2801 | { | |
2802 | gfc_filepos *fp; | |
2803 | match m; | |
2804 | ||
ece3f663 | 2805 | fp = XCNEW (gfc_filepos); |
6de9cd9a DN |
2806 | |
2807 | if (gfc_match_char ('(') == MATCH_NO) | |
2808 | { | |
2809 | m = gfc_match_expr (&fp->unit); | |
2810 | if (m == MATCH_ERROR) | |
2811 | goto cleanup; | |
2812 | if (m == MATCH_NO) | |
2813 | goto syntax; | |
2814 | ||
2815 | goto done; | |
2816 | } | |
2817 | ||
2818 | m = match_file_element (fp); | |
2819 | if (m == MATCH_ERROR) | |
939e9f69 | 2820 | goto cleanup; |
6de9cd9a DN |
2821 | if (m == MATCH_NO) |
2822 | { | |
2823 | m = gfc_match_expr (&fp->unit); | |
20898e80 | 2824 | if (m == MATCH_ERROR || m == MATCH_NO) |
6de9cd9a DN |
2825 | goto syntax; |
2826 | } | |
2827 | ||
2828 | for (;;) | |
2829 | { | |
2830 | if (gfc_match_char (')') == MATCH_YES) | |
2831 | break; | |
2832 | if (gfc_match_char (',') != MATCH_YES) | |
2833 | goto syntax; | |
2834 | ||
2835 | m = match_file_element (fp); | |
2836 | if (m == MATCH_ERROR) | |
2837 | goto cleanup; | |
2838 | if (m == MATCH_NO) | |
2839 | goto syntax; | |
2840 | } | |
2841 | ||
2842 | done: | |
2843 | if (gfc_match_eos () != MATCH_YES) | |
2844 | goto syntax; | |
2845 | ||
2846 | if (gfc_pure (NULL)) | |
2847 | { | |
2848 | gfc_error ("%s statement not allowed in PURE procedure at %C", | |
2849 | gfc_ascii_statement (st)); | |
2850 | ||
2851 | goto cleanup; | |
2852 | } | |
2853 | ||
ccd7751b | 2854 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 2855 | |
6de9cd9a DN |
2856 | new_st.op = op; |
2857 | new_st.ext.filepos = fp; | |
2858 | return MATCH_YES; | |
2859 | ||
2860 | syntax: | |
2861 | gfc_syntax_error (st); | |
2862 | ||
2863 | cleanup: | |
2864 | gfc_free_filepos (fp); | |
2865 | return MATCH_ERROR; | |
2866 | } | |
2867 | ||
2868 | ||
524af0d6 | 2869 | bool |
3d07fb21 | 2870 | gfc_resolve_filepos (gfc_filepos *fp, locus *where) |
6de9cd9a | 2871 | { |
6de9cd9a | 2872 | RESOLVE_TAG (&tag_unit, fp->unit); |
7aba8abe TK |
2873 | RESOLVE_TAG (&tag_iostat, fp->iostat); |
2874 | RESOLVE_TAG (&tag_iomsg, fp->iomsg); | |
6de9cd9a | 2875 | |
3d07fb21 | 2876 | if (!fp->unit && (fp->iostat || fp->iomsg || fp->err)) |
220ab6b4 | 2877 | { |
3d07fb21 | 2878 | gfc_error ("UNIT number missing in statement at %L", where); |
220ab6b4 SK |
2879 | return false; |
2880 | } | |
2881 | ||
3d07fb21 SK |
2882 | if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) |
2883 | return false; | |
2884 | ||
9ad55c33 JD |
2885 | if (fp->unit->expr_type == EXPR_CONSTANT |
2886 | && fp->unit->ts.type == BT_INTEGER | |
2887 | && mpz_sgn (fp->unit->value.integer) < 0) | |
2888 | { | |
2889 | gfc_error ("UNIT number in statement at %L must be non-negative", | |
2890 | &fp->unit->where); | |
220ab6b4 | 2891 | return false; |
9ad55c33 JD |
2892 | } |
2893 | ||
524af0d6 | 2894 | return true; |
6de9cd9a DN |
2895 | } |
2896 | ||
2897 | ||
6403ec5f JB |
2898 | /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND, |
2899 | and the FLUSH statement. */ | |
6de9cd9a DN |
2900 | |
2901 | match | |
2902 | gfc_match_endfile (void) | |
2903 | { | |
6de9cd9a DN |
2904 | return match_filepos (ST_END_FILE, EXEC_ENDFILE); |
2905 | } | |
2906 | ||
2907 | match | |
2908 | gfc_match_backspace (void) | |
2909 | { | |
6de9cd9a DN |
2910 | return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE); |
2911 | } | |
2912 | ||
2913 | match | |
2914 | gfc_match_rewind (void) | |
2915 | { | |
6de9cd9a DN |
2916 | return match_filepos (ST_REWIND, EXEC_REWIND); |
2917 | } | |
2918 | ||
6403ec5f JB |
2919 | match |
2920 | gfc_match_flush (void) | |
2921 | { | |
524af0d6 | 2922 | if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C")) |
6403ec5f JB |
2923 | return MATCH_ERROR; |
2924 | ||
2925 | return match_filepos (ST_FLUSH, EXEC_FLUSH); | |
2926 | } | |
6de9cd9a | 2927 | |
e7dc5b4f | 2928 | /******************** Data Transfer Statements *********************/ |
6de9cd9a | 2929 | |
6de9cd9a DN |
2930 | /* Return a default unit number. */ |
2931 | ||
2932 | static gfc_expr * | |
2933 | default_unit (io_kind k) | |
2934 | { | |
2935 | int unit; | |
2936 | ||
2937 | if (k == M_READ) | |
2938 | unit = 5; | |
2939 | else | |
2940 | unit = 6; | |
2941 | ||
b7e75771 | 2942 | return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit); |
6de9cd9a DN |
2943 | } |
2944 | ||
2945 | ||
2946 | /* Match a unit specification for a data transfer statement. */ | |
2947 | ||
2948 | static match | |
b251af97 | 2949 | match_dt_unit (io_kind k, gfc_dt *dt) |
6de9cd9a DN |
2950 | { |
2951 | gfc_expr *e; | |
e3228a50 | 2952 | char c; |
6de9cd9a DN |
2953 | |
2954 | if (gfc_match_char ('*') == MATCH_YES) | |
2955 | { | |
2956 | if (dt->io_unit != NULL) | |
2957 | goto conflict; | |
2958 | ||
2959 | dt->io_unit = default_unit (k); | |
e3228a50 JD |
2960 | |
2961 | c = gfc_peek_ascii_char (); | |
2962 | if (c == ')') | |
2963 | gfc_error_now ("Missing format with default unit at %C"); | |
2964 | ||
6de9cd9a DN |
2965 | return MATCH_YES; |
2966 | } | |
2967 | ||
2968 | if (gfc_match_expr (&e) == MATCH_YES) | |
2969 | { | |
2970 | if (dt->io_unit != NULL) | |
2971 | { | |
2972 | gfc_free_expr (e); | |
2973 | goto conflict; | |
2974 | } | |
2975 | ||
2976 | dt->io_unit = e; | |
2977 | return MATCH_YES; | |
2978 | } | |
2979 | ||
2980 | return MATCH_NO; | |
2981 | ||
2982 | conflict: | |
2983 | gfc_error ("Duplicate UNIT specification at %C"); | |
2984 | return MATCH_ERROR; | |
2985 | } | |
2986 | ||
2987 | ||
2988 | /* Match a format specification. */ | |
2989 | ||
2990 | static match | |
b251af97 | 2991 | match_dt_format (gfc_dt *dt) |
6de9cd9a DN |
2992 | { |
2993 | locus where; | |
2994 | gfc_expr *e; | |
2995 | gfc_st_label *label; | |
a48ebf39 | 2996 | match m; |
6de9cd9a | 2997 | |
63645982 | 2998 | where = gfc_current_locus; |
6de9cd9a DN |
2999 | |
3000 | if (gfc_match_char ('*') == MATCH_YES) | |
3001 | { | |
3002 | if (dt->format_expr != NULL || dt->format_label != NULL) | |
3003 | goto conflict; | |
3004 | ||
3005 | dt->format_label = &format_asterisk; | |
3006 | return MATCH_YES; | |
3007 | } | |
3008 | ||
a48ebf39 | 3009 | if ((m = gfc_match_st_label (&label)) == MATCH_YES) |
6de9cd9a | 3010 | { |
fc3c9491 SK |
3011 | char c; |
3012 | ||
3013 | /* Need to check if the format label is actually either an operand | |
3014 | to a user-defined operator or is a kind type parameter. That is, | |
3015 | print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER. | |
3016 | print 1_'(I0)', i ! 1_'(I0)' is a default character string. */ | |
3017 | ||
3018 | gfc_gobble_whitespace (); | |
3019 | c = gfc_peek_ascii_char (); | |
3020 | if (c == '.' || c == '_') | |
3021 | gfc_current_locus = where; | |
3022 | else | |
6de9cd9a | 3023 | { |
fc3c9491 SK |
3024 | if (dt->format_expr != NULL || dt->format_label != NULL) |
3025 | { | |
3026 | gfc_free_st_label (label); | |
3027 | goto conflict; | |
3028 | } | |
6de9cd9a | 3029 | |
524af0d6 | 3030 | if (!gfc_reference_st_label (label, ST_LABEL_FORMAT)) |
fc3c9491 | 3031 | return MATCH_ERROR; |
6de9cd9a | 3032 | |
fc3c9491 SK |
3033 | dt->format_label = label; |
3034 | return MATCH_YES; | |
3035 | } | |
6de9cd9a | 3036 | } |
a48ebf39 FXC |
3037 | else if (m == MATCH_ERROR) |
3038 | /* The label was zero or too large. Emit the correct diagnosis. */ | |
3039 | return MATCH_ERROR; | |
6de9cd9a DN |
3040 | |
3041 | if (gfc_match_expr (&e) == MATCH_YES) | |
3042 | { | |
3043 | if (dt->format_expr != NULL || dt->format_label != NULL) | |
3044 | { | |
3045 | gfc_free_expr (e); | |
3046 | goto conflict; | |
3047 | } | |
6de9cd9a DN |
3048 | dt->format_expr = e; |
3049 | return MATCH_YES; | |
3050 | } | |
3051 | ||
63645982 | 3052 | gfc_current_locus = where; /* The only case where we have to restore */ |
6de9cd9a DN |
3053 | |
3054 | return MATCH_NO; | |
3055 | ||
3056 | conflict: | |
3057 | gfc_error ("Duplicate format specification at %C"); | |
3058 | return MATCH_ERROR; | |
3059 | } | |
3060 | ||
628c06d6 JD |
3061 | /* Check for formatted read and write DTIO procedures. */ |
3062 | ||
3063 | static bool | |
3064 | dtio_procs_present (gfc_symbol *sym, io_kind k) | |
3065 | { | |
3066 | gfc_symbol *derived; | |
3067 | ||
3068 | if (sym && sym->ts.u.derived) | |
3069 | { | |
3070 | if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) | |
3071 | derived = CLASS_DATA (sym)->ts.u.derived; | |
3072 | else if (sym->ts.type == BT_DERIVED) | |
3073 | derived = sym->ts.u.derived; | |
3074 | else | |
3075 | return false; | |
3076 | if ((k == M_WRITE || k == M_PRINT) && | |
3077 | (gfc_find_specific_dtio_proc (derived, true, true) != NULL)) | |
3078 | return true; | |
3079 | if ((k == M_READ) && | |
3080 | (gfc_find_specific_dtio_proc (derived, false, true) != NULL)) | |
3081 | return true; | |
3082 | } | |
3083 | return false; | |
3084 | } | |
6de9cd9a DN |
3085 | |
3086 | /* Traverse a namelist that is part of a READ statement to make sure | |
3087 | that none of the variables in the namelist are INTENT(IN). Returns | |
3088 | nonzero if we find such a variable. */ | |
3089 | ||
3090 | static int | |
b251af97 | 3091 | check_namelist (gfc_symbol *sym) |
6de9cd9a DN |
3092 | { |
3093 | gfc_namelist *p; | |
3094 | ||
3095 | for (p = sym->namelist; p; p = p->next) | |
3096 | if (p->sym->attr.intent == INTENT_IN) | |
3097 | { | |
a4d9b221 | 3098 | gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C", |
6de9cd9a DN |
3099 | p->sym->name, sym->name); |
3100 | return 1; | |
3101 | } | |
3102 | ||
3103 | return 0; | |
3104 | } | |
3105 | ||
3106 | ||
3107 | /* Match a single data transfer element. */ | |
3108 | ||
3109 | static match | |
b251af97 | 3110 | match_dt_element (io_kind k, gfc_dt *dt) |
6de9cd9a DN |
3111 | { |
3112 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
3113 | gfc_symbol *sym; | |
3114 | match m; | |
3115 | ||
3116 | if (gfc_match (" unit =") == MATCH_YES) | |
3117 | { | |
3118 | m = match_dt_unit (k, dt); | |
3119 | if (m != MATCH_NO) | |
3120 | return m; | |
3121 | } | |
3122 | ||
3123 | if (gfc_match (" fmt =") == MATCH_YES) | |
3124 | { | |
3125 | m = match_dt_format (dt); | |
3126 | if (m != MATCH_NO) | |
3127 | return m; | |
3128 | } | |
3129 | ||
3130 | if (gfc_match (" nml = %n", name) == MATCH_YES) | |
3131 | { | |
3132 | if (dt->namelist != NULL) | |
3133 | { | |
3134 | gfc_error ("Duplicate NML specification at %C"); | |
3135 | return MATCH_ERROR; | |
3136 | } | |
3137 | ||
3138 | if (gfc_find_symbol (name, NULL, 1, &sym)) | |
3139 | return MATCH_ERROR; | |
3140 | ||
3141 | if (sym == NULL || sym->attr.flavor != FL_NAMELIST) | |
3142 | { | |
a4d9b221 | 3143 | gfc_error ("Symbol %qs at %C must be a NAMELIST group name", |
6de9cd9a DN |
3144 | sym != NULL ? sym->name : name); |
3145 | return MATCH_ERROR; | |
3146 | } | |
3147 | ||
3148 | dt->namelist = sym; | |
3149 | if (k == M_READ && check_namelist (sym)) | |
3150 | return MATCH_ERROR; | |
3151 | ||
3152 | return MATCH_YES; | |
3153 | } | |
3154 | ||
d06b3496 | 3155 | m = match_etag (&tag_e_async, &dt->asynchronous); |
6f0f0b2e JD |
3156 | if (m != MATCH_NO) |
3157 | return m; | |
3158 | m = match_etag (&tag_e_blank, &dt->blank); | |
3159 | if (m != MATCH_NO) | |
3160 | return m; | |
3161 | m = match_etag (&tag_e_delim, &dt->delim); | |
3162 | if (m != MATCH_NO) | |
3163 | return m; | |
3164 | m = match_etag (&tag_e_pad, &dt->pad); | |
3165 | if (m != MATCH_NO) | |
3166 | return m; | |
3167 | m = match_etag (&tag_e_sign, &dt->sign); | |
3168 | if (m != MATCH_NO) | |
3169 | return m; | |
3170 | m = match_etag (&tag_e_round, &dt->round); | |
3171 | if (m != MATCH_NO) | |
3172 | return m; | |
3173 | m = match_out_tag (&tag_id, &dt->id); | |
3174 | if (m != MATCH_NO) | |
3175 | return m; | |
3176 | m = match_etag (&tag_e_decimal, &dt->decimal); | |
3177 | if (m != MATCH_NO) | |
3178 | return m; | |
6de9cd9a | 3179 | m = match_etag (&tag_rec, &dt->rec); |
014ec6ee JD |
3180 | if (m != MATCH_NO) |
3181 | return m; | |
4c934d41 | 3182 | m = match_etag (&tag_spos, &dt->pos); |
7aba8abe TK |
3183 | if (m != MATCH_NO) |
3184 | return m; | |
fd5cabb2 | 3185 | m = match_etag (&tag_iomsg, &dt->iomsg); |
6de9cd9a DN |
3186 | if (m != MATCH_NO) |
3187 | return m; | |
2e431643 | 3188 | |
c9583ed2 | 3189 | m = match_out_tag (&tag_iostat, &dt->iostat); |
6de9cd9a DN |
3190 | if (m != MATCH_NO) |
3191 | return m; | |
3192 | m = match_ltag (&tag_err, &dt->err); | |
e0e85e06 PT |
3193 | if (m == MATCH_YES) |
3194 | dt->err_where = gfc_current_locus; | |
6de9cd9a DN |
3195 | if (m != MATCH_NO) |
3196 | return m; | |
3197 | m = match_etag (&tag_advance, &dt->advance); | |
3198 | if (m != MATCH_NO) | |
3199 | return m; | |
c9583ed2 | 3200 | m = match_out_tag (&tag_size, &dt->size); |
6de9cd9a DN |
3201 | if (m != MATCH_NO) |
3202 | return m; | |
3203 | ||
3204 | m = match_ltag (&tag_end, &dt->end); | |
3205 | if (m == MATCH_YES) | |
365ff3b9 FXC |
3206 | { |
3207 | if (k == M_WRITE) | |
3208 | { | |
b251af97 SK |
3209 | gfc_error ("END tag at %C not allowed in output statement"); |
3210 | return MATCH_ERROR; | |
365ff3b9 FXC |
3211 | } |
3212 | dt->end_where = gfc_current_locus; | |
3213 | } | |
6de9cd9a DN |
3214 | if (m != MATCH_NO) |
3215 | return m; | |
3216 | ||
3217 | m = match_ltag (&tag_eor, &dt->eor); | |
3218 | if (m == MATCH_YES) | |
63645982 | 3219 | dt->eor_where = gfc_current_locus; |
6de9cd9a DN |
3220 | if (m != MATCH_NO) |
3221 | return m; | |
3222 | ||
3223 | return MATCH_NO; | |
3224 | } | |
3225 | ||
3226 | ||
3227 | /* Free a data transfer structure and everything below it. */ | |
3228 | ||
3229 | void | |
b251af97 | 3230 | gfc_free_dt (gfc_dt *dt) |
6de9cd9a | 3231 | { |
6de9cd9a DN |
3232 | if (dt == NULL) |
3233 | return; | |
3234 | ||
3235 | gfc_free_expr (dt->io_unit); | |
3236 | gfc_free_expr (dt->format_expr); | |
3237 | gfc_free_expr (dt->rec); | |
3238 | gfc_free_expr (dt->advance); | |
7aba8abe | 3239 | gfc_free_expr (dt->iomsg); |
6de9cd9a DN |
3240 | gfc_free_expr (dt->iostat); |
3241 | gfc_free_expr (dt->size); | |
6f0f0b2e JD |
3242 | gfc_free_expr (dt->pad); |
3243 | gfc_free_expr (dt->delim); | |
3244 | gfc_free_expr (dt->sign); | |
3245 | gfc_free_expr (dt->round); | |
3246 | gfc_free_expr (dt->blank); | |
3247 | gfc_free_expr (dt->decimal); | |
4c934d41 | 3248 | gfc_free_expr (dt->pos); |
8e8dc060 DK |
3249 | gfc_free_expr (dt->dt_io_kind); |
3250 | /* dt->extra_comma is a link to dt_io_kind if it is set. */ | |
cede9502 | 3251 | free (dt); |
6de9cd9a DN |
3252 | } |
3253 | ||
3254 | ||
44facdb7 FR |
3255 | static const char * |
3256 | io_kind_name (io_kind k); | |
3257 | ||
3258 | static bool | |
3259 | check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, | |
3260 | locus *spec_end); | |
3261 | ||
6de9cd9a DN |
3262 | /* Resolve everything in a gfc_dt structure. */ |
3263 | ||
524af0d6 | 3264 | bool |
44facdb7 | 3265 | gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc) |
6de9cd9a DN |
3266 | { |
3267 | gfc_expr *e; | |
8e8dc060 DK |
3268 | io_kind k; |
3269 | ||
3270 | /* This is set in any case. */ | |
3271 | gcc_assert (dt->dt_io_kind); | |
3272 | k = dt->dt_io_kind->value.iokind; | |
6de9cd9a | 3273 | |
44facdb7 | 3274 | RESOLVE_TAG (&tag_format, dt->format_expr); |
6de9cd9a | 3275 | RESOLVE_TAG (&tag_rec, dt->rec); |
4c934d41 | 3276 | RESOLVE_TAG (&tag_spos, dt->pos); |
6de9cd9a | 3277 | RESOLVE_TAG (&tag_advance, dt->advance); |
3446fc50 | 3278 | RESOLVE_TAG (&tag_id, dt->id); |
7aba8abe | 3279 | RESOLVE_TAG (&tag_iomsg, dt->iomsg); |
6de9cd9a DN |
3280 | RESOLVE_TAG (&tag_iostat, dt->iostat); |
3281 | RESOLVE_TAG (&tag_size, dt->size); | |
6f0f0b2e JD |
3282 | RESOLVE_TAG (&tag_e_pad, dt->pad); |
3283 | RESOLVE_TAG (&tag_e_delim, dt->delim); | |
3284 | RESOLVE_TAG (&tag_e_sign, dt->sign); | |
3285 | RESOLVE_TAG (&tag_e_round, dt->round); | |
3286 | RESOLVE_TAG (&tag_e_blank, dt->blank); | |
3287 | RESOLVE_TAG (&tag_e_decimal, dt->decimal); | |
3446fc50 | 3288 | RESOLVE_TAG (&tag_e_async, dt->asynchronous); |
6de9cd9a | 3289 | |
44facdb7 FR |
3290 | /* Check I/O constraints. |
3291 | To validate NAMELIST we need to check if we were also given an I/O list, | |
3292 | which is stored in code->block->next with op EXEC_TRANSFER. | |
3293 | Note that the I/O list was already resolved from resolve_transfer. */ | |
3294 | gfc_code *io_code = NULL; | |
3295 | if (dt_code && dt_code->block && dt_code->block->next | |
3296 | && dt_code->block->next->op == EXEC_TRANSFER) | |
3297 | io_code = dt_code->block->next; | |
3298 | ||
3299 | if (!check_io_constraints (k, dt, io_code, loc)) | |
3300 | return false; | |
3301 | ||
6de9cd9a | 3302 | e = dt->io_unit; |
88e18fed JJ |
3303 | if (e == NULL) |
3304 | { | |
3305 | gfc_error ("UNIT not specified at %L", loc); | |
524af0d6 | 3306 | return false; |
88e18fed JJ |
3307 | } |
3308 | ||
b1be0054 JD |
3309 | if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER |
3310 | && e->ts.type == BT_CHARACTER) | |
3311 | { | |
3312 | gfc_error ("UNIT specification at %L must " | |
3313 | "not be a character PARAMETER", &e->where); | |
3314 | return false; | |
3315 | } | |
3316 | ||
524af0d6 | 3317 | if (gfc_resolve_expr (e) |
6de9cd9a | 3318 | && (e->ts.type != BT_INTEGER |
b251af97 | 3319 | && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE))) |
6de9cd9a | 3320 | { |
ad7ee6f8 JD |
3321 | /* If there is no extra comma signifying the "format" form of the IO |
3322 | statement, then this must be an error. */ | |
3323 | if (!dt->extra_comma) | |
3324 | { | |
3325 | gfc_error ("UNIT specification at %L must be an INTEGER expression " | |
3326 | "or a CHARACTER variable", &e->where); | |
524af0d6 | 3327 | return false; |
ad7ee6f8 JD |
3328 | } |
3329 | else | |
3330 | { | |
3331 | /* At this point, we have an extra comma. If io_unit has arrived as | |
df2fba9e | 3332 | type character, we assume its really the "format" form of the I/O |
ad7ee6f8 | 3333 | statement. We set the io_unit to the default unit and format to |
df2fba9e | 3334 | the character expression. See F95 Standard section 9.4. */ |
ad7ee6f8 JD |
3335 | if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) |
3336 | { | |
3337 | dt->format_expr = dt->io_unit; | |
3338 | dt->io_unit = default_unit (k); | |
3339 | ||
8e8dc060 DK |
3340 | /* Nullify this pointer now so that a warning/error is not |
3341 | triggered below for the "Extension". */ | |
ad7ee6f8 JD |
3342 | dt->extra_comma = NULL; |
3343 | } | |
3344 | ||
3345 | if (k == M_WRITE) | |
3346 | { | |
3347 | gfc_error ("Invalid form of WRITE statement at %L, UNIT required", | |
3348 | &dt->extra_comma->where); | |
524af0d6 | 3349 | return false; |
ad7ee6f8 JD |
3350 | } |
3351 | } | |
6de9cd9a DN |
3352 | } |
3353 | ||
6de9cd9a DN |
3354 | if (e->ts.type == BT_CHARACTER) |
3355 | { | |
4075a94e PT |
3356 | if (gfc_has_vector_index (e)) |
3357 | { | |
b251af97 | 3358 | gfc_error ("Internal unit with vector subscript at %L", &e->where); |
524af0d6 | 3359 | return false; |
4075a94e | 3360 | } |
8e8dc060 DK |
3361 | |
3362 | /* If we are writing, make sure the internal unit can be changed. */ | |
3363 | gcc_assert (k != M_PRINT); | |
3364 | if (k == M_WRITE | |
524af0d6 JB |
3365 | && !gfc_check_vardef_context (e, false, false, false, |
3366 | _("internal unit in WRITE"))) | |
3367 | return false; | |
e0e85e06 | 3368 | } |
4075a94e | 3369 | |
e0e85e06 PT |
3370 | if (e->rank && e->ts.type != BT_CHARACTER) |
3371 | { | |
3372 | gfc_error ("External IO UNIT cannot be an array at %L", &e->where); | |
524af0d6 | 3373 | return false; |
6de9cd9a DN |
3374 | } |
3375 | ||
9ad55c33 JD |
3376 | if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER |
3377 | && mpz_sgn (e->value.integer) < 0) | |
3378 | { | |
8e8dc060 DK |
3379 | gfc_error ("UNIT number in statement at %L must be non-negative", |
3380 | &e->where); | |
524af0d6 | 3381 | return false; |
9ad55c33 JD |
3382 | } |
3383 | ||
8e8dc060 DK |
3384 | /* If we are reading and have a namelist, check that all namelist symbols |
3385 | can appear in a variable definition context. */ | |
628c06d6 | 3386 | if (dt->namelist) |
8e8dc060 DK |
3387 | { |
3388 | gfc_namelist* n; | |
3389 | for (n = dt->namelist->namelist; n; n = n->next) | |
3390 | { | |
3391 | gfc_expr* e; | |
524af0d6 | 3392 | bool t; |
8e8dc060 | 3393 | |
628c06d6 JD |
3394 | if (k == M_READ) |
3395 | { | |
3396 | e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); | |
3397 | t = gfc_check_vardef_context (e, false, false, false, NULL); | |
3398 | gfc_free_expr (e); | |
3399 | ||
3400 | if (!t) | |
3401 | { | |
3402 | gfc_error ("NAMELIST %qs in READ statement at %L contains" | |
3403 | " the symbol %qs which may not appear in a" | |
3404 | " variable definition context", | |
3405 | dt->namelist->name, loc, n->sym->name); | |
3406 | return false; | |
3407 | } | |
3408 | } | |
8e8dc060 | 3409 | |
628c06d6 JD |
3410 | t = dtio_procs_present (n->sym, k); |
3411 | ||
3412 | if (n->sym->ts.type == BT_CLASS && !t) | |
8e8dc060 | 3413 | { |
628c06d6 JD |
3414 | gfc_error ("NAMELIST object %qs in namelist %qs at %L is " |
3415 | "polymorphic and requires a defined input/output " | |
3416 | "procedure", n->sym->name, dt->namelist->name, loc); | |
2263019d | 3417 | return false; |
628c06d6 JD |
3418 | } |
3419 | ||
3420 | if ((n->sym->ts.type == BT_DERIVED) | |
3421 | && (n->sym->ts.u.derived->attr.alloc_comp | |
3422 | || n->sym->ts.u.derived->attr.pointer_comp)) | |
3423 | { | |
3424 | if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " | |
3425 | "namelist %qs at %L with ALLOCATABLE " | |
3426 | "or POINTER components", n->sym->name, | |
3427 | dt->namelist->name, loc)) | |
2263019d | 3428 | return false; |
628c06d6 JD |
3429 | |
3430 | if (!t) | |
3431 | { | |
3432 | gfc_error ("NAMELIST object %qs in namelist %qs at %L has " | |
3433 | "ALLOCATABLE or POINTER components and thus requires " | |
3434 | "a defined input/output procedure", n->sym->name, | |
3435 | dt->namelist->name, loc); | |
2263019d | 3436 | return false; |
628c06d6 | 3437 | } |
8e8dc060 DK |
3438 | } |
3439 | } | |
3440 | } | |
3441 | ||
ad7ee6f8 | 3442 | if (dt->extra_comma |
d3dc025d | 3443 | && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L", |
524af0d6 JB |
3444 | &dt->extra_comma->where)) |
3445 | return false; | |
ad7ee6f8 | 3446 | |
e0e85e06 | 3447 | if (dt->err) |
6de9cd9a | 3448 | { |
524af0d6 JB |
3449 | if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET)) |
3450 | return false; | |
e0e85e06 | 3451 | if (dt->err->defined == ST_LABEL_UNKNOWN) |
6de9cd9a | 3452 | { |
e0e85e06 PT |
3453 | gfc_error ("ERR tag label %d at %L not defined", |
3454 | dt->err->value, &dt->err_where); | |
524af0d6 | 3455 | return false; |
6de9cd9a | 3456 | } |
e0e85e06 | 3457 | } |
6de9cd9a | 3458 | |
e0e85e06 PT |
3459 | if (dt->end) |
3460 | { | |
524af0d6 JB |
3461 | if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET)) |
3462 | return false; | |
e0e85e06 | 3463 | if (dt->end->defined == ST_LABEL_UNKNOWN) |
6de9cd9a | 3464 | { |
e0e85e06 PT |
3465 | gfc_error ("END tag label %d at %L not defined", |
3466 | dt->end->value, &dt->end_where); | |
524af0d6 | 3467 | return false; |
6de9cd9a | 3468 | } |
e0e85e06 | 3469 | } |
6de9cd9a | 3470 | |
e0e85e06 PT |
3471 | if (dt->eor) |
3472 | { | |
524af0d6 JB |
3473 | if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET)) |
3474 | return false; | |
e0e85e06 | 3475 | if (dt->eor->defined == ST_LABEL_UNKNOWN) |
6de9cd9a | 3476 | { |
e0e85e06 PT |
3477 | gfc_error ("EOR tag label %d at %L not defined", |
3478 | dt->eor->value, &dt->eor_where); | |
524af0d6 | 3479 | return false; |
6de9cd9a DN |
3480 | } |
3481 | } | |
3482 | ||
1f2959f0 | 3483 | /* Check the format label actually exists. */ |
6de9cd9a DN |
3484 | if (dt->format_label && dt->format_label != &format_asterisk |
3485 | && dt->format_label->defined == ST_LABEL_UNKNOWN) | |
3486 | { | |
3487 | gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value, | |
712dff31 | 3488 | loc); |
524af0d6 | 3489 | return false; |
6de9cd9a | 3490 | } |
8e8dc060 | 3491 | |
524af0d6 | 3492 | return true; |
6de9cd9a DN |
3493 | } |
3494 | ||
3495 | ||
3496 | /* Given an io_kind, return its name. */ | |
3497 | ||
3498 | static const char * | |
3499 | io_kind_name (io_kind k) | |
3500 | { | |
3501 | const char *name; | |
3502 | ||
3503 | switch (k) | |
3504 | { | |
3505 | case M_READ: | |
3506 | name = "READ"; | |
3507 | break; | |
3508 | case M_WRITE: | |
3509 | name = "WRITE"; | |
3510 | break; | |
3511 | case M_PRINT: | |
3512 | name = "PRINT"; | |
3513 | break; | |
3514 | case M_INQUIRE: | |
3515 | name = "INQUIRE"; | |
3516 | break; | |
3517 | default: | |
3518 | gfc_internal_error ("io_kind_name(): bad I/O-kind"); | |
3519 | } | |
3520 | ||
3521 | return name; | |
3522 | } | |
3523 | ||
3524 | ||
3525 | /* Match an IO iteration statement of the form: | |
3526 | ||
3527 | ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] ) | |
3528 | ||
3529 | which is equivalent to a single IO element. This function is | |
3530 | mutually recursive with match_io_element(). */ | |
3531 | ||
b251af97 | 3532 | static match match_io_element (io_kind, gfc_code **); |
6de9cd9a DN |
3533 | |
3534 | static match | |
b251af97 | 3535 | match_io_iterator (io_kind k, gfc_code **result) |
6de9cd9a | 3536 | { |
7b901ac4 | 3537 | gfc_code *head, *tail, *new_code; |
6de9cd9a DN |
3538 | gfc_iterator *iter; |
3539 | locus old_loc; | |
3540 | match m; | |
3541 | int n; | |
3542 | ||
3543 | iter = NULL; | |
3544 | head = NULL; | |
63645982 | 3545 | old_loc = gfc_current_locus; |
6de9cd9a DN |
3546 | |
3547 | if (gfc_match_char ('(') != MATCH_YES) | |
3548 | return MATCH_NO; | |
3549 | ||
3550 | m = match_io_element (k, &head); | |
3551 | tail = head; | |
3552 | ||
3553 | if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES) | |
3554 | { | |
3555 | m = MATCH_NO; | |
3556 | goto cleanup; | |
3557 | } | |
3558 | ||
3559 | /* Can't be anything but an IO iterator. Build a list. */ | |
3560 | iter = gfc_get_iterator (); | |
3561 | ||
3562 | for (n = 1;; n++) | |
3563 | { | |
3564 | m = gfc_match_iterator (iter, 0); | |
3565 | if (m == MATCH_ERROR) | |
3566 | goto cleanup; | |
3567 | if (m == MATCH_YES) | |
c9583ed2 TS |
3568 | { |
3569 | gfc_check_do_variable (iter->var->symtree); | |
3570 | break; | |
3571 | } | |
6de9cd9a | 3572 | |
7b901ac4 | 3573 | m = match_io_element (k, &new_code); |
6de9cd9a DN |
3574 | if (m == MATCH_ERROR) |
3575 | goto cleanup; | |
3576 | if (m == MATCH_NO) | |
3577 | { | |
3578 | if (n > 2) | |
3579 | goto syntax; | |
3580 | goto cleanup; | |
3581 | } | |
3582 | ||
7b901ac4 | 3583 | tail = gfc_append_code (tail, new_code); |
6de9cd9a DN |
3584 | |
3585 | if (gfc_match_char (',') != MATCH_YES) | |
3586 | { | |
3587 | if (n > 2) | |
3588 | goto syntax; | |
3589 | m = MATCH_NO; | |
3590 | goto cleanup; | |
3591 | } | |
3592 | } | |
3593 | ||
3594 | if (gfc_match_char (')') != MATCH_YES) | |
3595 | goto syntax; | |
3596 | ||
11e5274a | 3597 | new_code = gfc_get_code (EXEC_DO); |
7b901ac4 | 3598 | new_code->ext.iterator = iter; |
6de9cd9a | 3599 | |
11e5274a | 3600 | new_code->block = gfc_get_code (EXEC_DO); |
7b901ac4 | 3601 | new_code->block->next = head; |
6de9cd9a | 3602 | |
7b901ac4 | 3603 | *result = new_code; |
6de9cd9a DN |
3604 | return MATCH_YES; |
3605 | ||
3606 | syntax: | |
3607 | gfc_error ("Syntax error in I/O iterator at %C"); | |
3608 | m = MATCH_ERROR; | |
3609 | ||
3610 | cleanup: | |
3611 | gfc_free_iterator (iter, 1); | |
3612 | gfc_free_statements (head); | |
63645982 | 3613 | gfc_current_locus = old_loc; |
6de9cd9a DN |
3614 | return m; |
3615 | } | |
3616 | ||
3617 | ||
3618 | /* Match a single element of an IO list, which is either a single | |
3619 | expression or an IO Iterator. */ | |
3620 | ||
3621 | static match | |
b251af97 | 3622 | match_io_element (io_kind k, gfc_code **cpp) |
6de9cd9a DN |
3623 | { |
3624 | gfc_expr *expr; | |
3625 | gfc_code *cp; | |
3626 | match m; | |
3627 | ||
3628 | expr = NULL; | |
3629 | ||
3630 | m = match_io_iterator (k, cpp); | |
3631 | if (m == MATCH_YES) | |
3632 | return MATCH_YES; | |
3633 | ||
3634 | if (k == M_READ) | |
3635 | { | |
3636 | m = gfc_match_variable (&expr, 0); | |
3637 | if (m == MATCH_NO) | |
036aa592 SK |
3638 | { |
3639 | gfc_error ("Expecting variable in READ statement at %C"); | |
3640 | m = MATCH_ERROR; | |
3641 | } | |
3642 | ||
3643 | if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT) | |
3644 | { | |
3645 | gfc_error ("Expecting variable or io-implied-do in READ statement " | |
3646 | "at %L", &expr->where); | |
3647 | m = MATCH_ERROR; | |
3648 | } | |
5131b898 SK |
3649 | |
3650 | if (m == MATCH_YES | |
3651 | && expr->expr_type == EXPR_VARIABLE | |
3652 | && expr->symtree->n.sym->attr.external) | |
3653 | { | |
3654 | gfc_error ("Expecting variable or io-implied-do at %L", | |
3655 | &expr->where); | |
3656 | m = MATCH_ERROR; | |
3657 | } | |
6de9cd9a DN |
3658 | } |
3659 | else | |
3660 | { | |
3661 | m = gfc_match_expr (&expr); | |
3662 | if (m == MATCH_NO) | |
3663 | gfc_error ("Expected expression in %s statement at %C", | |
3664 | io_kind_name (k)); | |
4844a5cb SK |
3665 | |
3666 | if (m == MATCH_YES && expr->ts.type == BT_BOZ) | |
3667 | { | |
3668 | if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in " | |
3669 | "an output IO list", &gfc_current_locus)) | |
3670 | return MATCH_ERROR; | |
3671 | if (!gfc_boz2int (expr, gfc_max_integer_kind)) | |
3672 | return MATCH_ERROR; | |
3673 | }; | |
6de9cd9a DN |
3674 | } |
3675 | ||
8e8dc060 DK |
3676 | if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree)) |
3677 | m = MATCH_ERROR; | |
6de9cd9a DN |
3678 | |
3679 | if (m != MATCH_YES) | |
3680 | { | |
3681 | gfc_free_expr (expr); | |
3682 | return MATCH_ERROR; | |
3683 | } | |
3684 | ||
11e5274a | 3685 | cp = gfc_get_code (EXEC_TRANSFER); |
a513927a | 3686 | cp->expr1 = expr; |
70b9ed88 JD |
3687 | if (k != M_INQUIRE) |
3688 | cp->ext.dt = current_dt; | |
6de9cd9a DN |
3689 | |
3690 | *cpp = cp; | |
3691 | return MATCH_YES; | |
3692 | } | |
3693 | ||
3694 | ||
3695 | /* Match an I/O list, building gfc_code structures as we go. */ | |
3696 | ||
3697 | static match | |
b251af97 | 3698 | match_io_list (io_kind k, gfc_code **head_p) |
6de9cd9a | 3699 | { |
7b901ac4 | 3700 | gfc_code *head, *tail, *new_code; |
6de9cd9a DN |
3701 | match m; |
3702 | ||
3703 | *head_p = head = tail = NULL; | |
3704 | if (gfc_match_eos () == MATCH_YES) | |
3705 | return MATCH_YES; | |
3706 | ||
3707 | for (;;) | |
3708 | { | |
7b901ac4 | 3709 | m = match_io_element (k, &new_code); |
6de9cd9a DN |
3710 | if (m == MATCH_ERROR) |
3711 | goto cleanup; | |
3712 | if (m == MATCH_NO) | |
3713 | goto syntax; | |
3714 | ||
7b901ac4 | 3715 | tail = gfc_append_code (tail, new_code); |
6de9cd9a | 3716 | if (head == NULL) |
7b901ac4 | 3717 | head = new_code; |
6de9cd9a DN |
3718 | |
3719 | if (gfc_match_eos () == MATCH_YES) | |
3720 | break; | |
3721 | if (gfc_match_char (',') != MATCH_YES) | |
3722 | goto syntax; | |
3723 | } | |
3724 | ||
3725 | *head_p = head; | |
3726 | return MATCH_YES; | |
3727 | ||
3728 | syntax: | |
3729 | gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); | |
3730 | ||
3731 | cleanup: | |
3732 | gfc_free_statements (head); | |
3733 | return MATCH_ERROR; | |
3734 | } | |
3735 | ||
3736 | ||
3737 | /* Attach the data transfer end node. */ | |
3738 | ||
3739 | static void | |
b251af97 | 3740 | terminate_io (gfc_code *io_code) |
6de9cd9a DN |
3741 | { |
3742 | gfc_code *c; | |
3743 | ||
3744 | if (io_code == NULL) | |
5e805e44 | 3745 | io_code = new_st.block; |
6de9cd9a | 3746 | |
11e5274a | 3747 | c = gfc_get_code (EXEC_DT_END); |
6de9cd9a DN |
3748 | |
3749 | /* Point to structure that is already there */ | |
3750 | c->ext.dt = new_st.ext.dt; | |
3751 | gfc_append_code (io_code, c); | |
3752 | } | |
3753 | ||
3754 | ||
e0e85e06 | 3755 | /* Check the constraints for a data transfer statement. The majority of the |
44facdb7 | 3756 | constraints appearing in 9.4 of the standard appear here. |
e0e85e06 | 3757 | |
44facdb7 FR |
3758 | Tag expressions are already resolved by resolve_tag, which includes |
3759 | verifying the type, that they are scalar, and verifying that BT_CHARACTER | |
3760 | tags are of default kind. */ | |
3761 | ||
3762 | static bool | |
b251af97 SK |
3763 | check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, |
3764 | locus *spec_end) | |
e0e85e06 | 3765 | { |
a8416251 | 3766 | #define io_constraint(condition, msg, arg)\ |
e0e85e06 PT |
3767 | if (condition) \ |
3768 | {\ | |
a8416251 SK |
3769 | if ((arg)->lb != NULL)\ |
3770 | gfc_error ((msg), (arg));\ | |
3771 | else\ | |
44facdb7 FR |
3772 | gfc_error ((msg), spec_end);\ |
3773 | return false;\ | |
e0e85e06 PT |
3774 | } |
3775 | ||
b251af97 SK |
3776 | gfc_expr *expr; |
3777 | gfc_symbol *sym = NULL; | |
6f0f0b2e JD |
3778 | bool warn, unformatted; |
3779 | ||
3780 | warn = (dt->err || dt->iostat) ? true : false; | |
3781 | unformatted = dt->format_expr == NULL && dt->format_label == NULL | |
3782 | && dt->namelist == NULL; | |
e0e85e06 | 3783 | |
e0e85e06 PT |
3784 | expr = dt->io_unit; |
3785 | if (expr && expr->expr_type == EXPR_VARIABLE | |
b251af97 | 3786 | && expr->ts.type == BT_CHARACTER) |
e0e85e06 PT |
3787 | { |
3788 | sym = expr->symtree->n.sym; | |
3789 | ||
3790 | io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN, | |
3791 | "Internal file at %L must not be INTENT(IN)", | |
3792 | &expr->where); | |
3793 | ||
3794 | io_constraint (gfc_has_vector_index (dt->io_unit), | |
3795 | "Internal file incompatible with vector subscript at %L", | |
3796 | &expr->where); | |
3797 | ||
3798 | io_constraint (dt->rec != NULL, | |
3799 | "REC tag at %L is incompatible with internal file", | |
3800 | &dt->rec->where); | |
44facdb7 | 3801 | |
f5c64803 JD |
3802 | io_constraint (dt->pos != NULL, |
3803 | "POS tag at %L is incompatible with internal file", | |
3804 | &dt->pos->where); | |
e0e85e06 | 3805 | |
6f0f0b2e | 3806 | io_constraint (unformatted, |
89c32b0f TB |
3807 | "Unformatted I/O not allowed with internal unit at %L", |
3808 | &dt->io_unit->where); | |
3809 | ||
6f0f0b2e JD |
3810 | io_constraint (dt->asynchronous != NULL, |
3811 | "ASYNCHRONOUS tag at %L not allowed with internal file", | |
3812 | &dt->asynchronous->where); | |
3813 | ||
f1827a8c | 3814 | if (dt->namelist != NULL) |
b251af97 | 3815 | { |
524af0d6 JB |
3816 | if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " |
3817 | "namelist", &expr->where)) | |
44facdb7 | 3818 | return false; |
b251af97 | 3819 | } |
e0e85e06 PT |
3820 | |
3821 | io_constraint (dt->advance != NULL, | |
3822 | "ADVANCE tag at %L is incompatible with internal file", | |
3823 | &dt->advance->where); | |
3824 | } | |
3825 | ||
3826 | if (expr && expr->ts.type != BT_CHARACTER) | |
3827 | { | |
3828 | ||
a8416251 SK |
3829 | if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE)) |
3830 | { | |
44facdb7 | 3831 | gfc_error ("IO UNIT in %s statement at %L must be " |
e0e85e06 | 3832 | "an internal file in a PURE procedure", |
44facdb7 FR |
3833 | io_kind_name (k), &expr->where); |
3834 | return false; | |
a8416251 | 3835 | } |
44facdb7 | 3836 | |
9964e830 TB |
3837 | if (k == M_READ || k == M_WRITE) |
3838 | gfc_unset_implicit_pure (NULL); | |
e0e85e06 PT |
3839 | } |
3840 | ||
44facdb7 | 3841 | if (dt->asynchronous) |
6f0f0b2e | 3842 | { |
27594524 | 3843 | int num = -1; |
6f0f0b2e JD |
3844 | static const char * asynchronous[] = { "YES", "NO", NULL }; |
3845 | ||
44facdb7 | 3846 | /* Note: gfc_reduce_init_expr reports an error if not init-expr. */ |
524af0d6 | 3847 | if (!gfc_reduce_init_expr (dt->asynchronous)) |
44facdb7 | 3848 | return false; |
87550b74 | 3849 | |
6f0f0b2e JD |
3850 | if (!compare_to_allowed_values |
3851 | ("ASYNCHRONOUS", asynchronous, NULL, NULL, | |
3852 | dt->asynchronous->value.character.string, | |
44facdb7 FR |
3853 | io_kind_name (k), warn, &dt->asynchronous->where, &num)) |
3854 | return false; | |
a4792d44 | 3855 | |
27594524 SSF |
3856 | gcc_checking_assert (num != -1); |
3857 | ||
44facdb7 FR |
3858 | /* For "YES", mark related symbols as asynchronous. */ |
3859 | if (num == 0) | |
3860 | { | |
3861 | /* SIZE variable. */ | |
3862 | if (dt->size) | |
3863 | dt->size->symtree->n.sym->attr.asynchronous = 1; | |
3864 | ||
3865 | /* Variables in a NAMELIST. */ | |
3866 | if (dt->namelist) | |
3867 | for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next) | |
3868 | nl->sym->attr.asynchronous = 1; | |
3869 | ||
3870 | /* Variables in an I/O list. */ | |
3871 | for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER; | |
3872 | xfer = xfer->next) | |
3873 | { | |
3874 | gfc_expr *expr = xfer->expr1; | |
3875 | while (expr != NULL && expr->expr_type == EXPR_OP | |
3876 | && expr->value.op.op == INTRINSIC_PARENTHESES) | |
3877 | expr = expr->value.op.op1; | |
3878 | ||
3879 | if (expr && expr->expr_type == EXPR_VARIABLE) | |
3880 | expr->symtree->n.sym->attr.asynchronous = 1; | |
3881 | } | |
3882 | } | |
6f0f0b2e JD |
3883 | } |
3884 | ||
3885 | if (dt->id) | |
3886 | { | |
00660189 FXC |
3887 | bool not_yes |
3888 | = !dt->asynchronous | |
3889 | || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 | |
3890 | || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, | |
3891 | "yes", 3) != 0; | |
3892 | io_constraint (not_yes, | |
d06b3496 | 3893 | "ID= specifier at %L must be with ASYNCHRONOUS='yes' " |
6f0f0b2e JD |
3894 | "specifier", &dt->id->where); |
3895 | } | |
3896 | ||
3897 | if (dt->decimal) | |
3898 | { | |
44facdb7 FR |
3899 | if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " |
3900 | "not allowed in Fortran 95", &dt->decimal->where)) | |
3901 | return false; | |
6f0f0b2e JD |
3902 | |
3903 | if (dt->decimal->expr_type == EXPR_CONSTANT) | |
3904 | { | |
3905 | static const char * decimal[] = { "COMMA", "POINT", NULL }; | |
3906 | ||
3907 | if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, | |
3908 | dt->decimal->value.character.string, | |
44facdb7 FR |
3909 | io_kind_name (k), warn, |
3910 | &dt->decimal->where)) | |
3911 | return false; | |
6f0f0b2e JD |
3912 | |
3913 | io_constraint (unformatted, | |
d06b3496 | 3914 | "the DECIMAL= specifier at %L must be with an " |
6f0f0b2e JD |
3915 | "explicit format expression", &dt->decimal->where); |
3916 | } | |
3917 | } | |
44facdb7 | 3918 | |
6f0f0b2e JD |
3919 | if (dt->blank) |
3920 | { | |
44facdb7 FR |
3921 | if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " |
3922 | "not allowed in Fortran 95", &dt->blank->where)) | |
3923 | return false; | |
2e431643 | 3924 | |
6f0f0b2e JD |
3925 | if (dt->blank->expr_type == EXPR_CONSTANT) |
3926 | { | |
3927 | static const char * blank[] = { "NULL", "ZERO", NULL }; | |
3928 | ||
2e431643 | 3929 | |
6f0f0b2e JD |
3930 | if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, |
3931 | dt->blank->value.character.string, | |
44facdb7 FR |
3932 | io_kind_name (k), warn, |
3933 | &dt->blank->where)) | |
3934 | return false; | |
6f0f0b2e JD |
3935 | |
3936 | io_constraint (unformatted, | |
d06b3496 | 3937 | "the BLANK= specifier at %L must be with an " |
6f0f0b2e JD |
3938 | "explicit format expression", &dt->blank->where); |
3939 | } | |
3940 | } | |
3941 | ||
3942 | if (dt->pad) | |
3943 | { | |
44facdb7 FR |
3944 | if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L " |
3945 | "not allowed in Fortran 95", &dt->pad->where)) | |
3946 | return false; | |
2e431643 | 3947 | |
6f0f0b2e JD |
3948 | if (dt->pad->expr_type == EXPR_CONSTANT) |
3949 | { | |
3950 | static const char * pad[] = { "YES", "NO", NULL }; | |
3951 | ||
3952 | if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, | |
3953 | dt->pad->value.character.string, | |
44facdb7 FR |
3954 | io_kind_name (k), warn, |
3955 | &dt->pad->where)) | |
3956 | return false; | |
6f0f0b2e JD |
3957 | |
3958 | io_constraint (unformatted, | |
d06b3496 | 3959 | "the PAD= specifier at %L must be with an " |
6f0f0b2e JD |
3960 | "explicit format expression", &dt->pad->where); |
3961 | } | |
3962 | } | |
3963 | ||
3964 | if (dt->round) | |
3965 | { | |
44facdb7 FR |
3966 | if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " |
3967 | "not allowed in Fortran 95", &dt->round->where)) | |
3968 | return false; | |
2e431643 | 3969 | |
6f0f0b2e JD |
3970 | if (dt->round->expr_type == EXPR_CONSTANT) |
3971 | { | |
3972 | static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", | |
3973 | "COMPATIBLE", "PROCESSOR_DEFINED", | |
3974 | NULL }; | |
3975 | ||
3976 | if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, | |
3977 | dt->round->value.character.string, | |
44facdb7 FR |
3978 | io_kind_name (k), warn, |
3979 | &dt->round->where)) | |
3980 | return false; | |
6f0f0b2e JD |
3981 | } |
3982 | } | |
44facdb7 | 3983 | |
6f0f0b2e JD |
3984 | if (dt->sign) |
3985 | { | |
3986 | /* When implemented, change the following to use gfc_notify_std F2003. | |
44facdb7 FR |
3987 | if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " |
3988 | "not allowed in Fortran 95", &dt->sign->where) == false) | |
3989 | return false; */ | |
2e431643 | 3990 | |
6f0f0b2e JD |
3991 | if (dt->sign->expr_type == EXPR_CONSTANT) |
3992 | { | |
3993 | static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", | |
3994 | NULL }; | |
3995 | ||
3996 | if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, | |
3997 | dt->sign->value.character.string, | |
44facdb7 FR |
3998 | io_kind_name (k), warn, &dt->sign->where)) |
3999 | return false; | |
6f0f0b2e JD |
4000 | |
4001 | io_constraint (unformatted, | |
d06b3496 | 4002 | "SIGN= specifier at %L must be with an " |
6f0f0b2e | 4003 | "explicit format expression", &dt->sign->where); |
e0e85e06 | 4004 | |
6f0f0b2e | 4005 | io_constraint (k == M_READ, |
d06b3496 | 4006 | "SIGN= specifier at %L not allowed in a " |
6f0f0b2e JD |
4007 | "READ statement", &dt->sign->where); |
4008 | } | |
4009 | } | |
4010 | ||
4011 | if (dt->delim) | |
4012 | { | |
44facdb7 FR |
4013 | if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L " |
4014 | "not allowed in Fortran 95", &dt->delim->where)) | |
4015 | return false; | |
2e431643 | 4016 | |
6f0f0b2e JD |
4017 | if (dt->delim->expr_type == EXPR_CONSTANT) |
4018 | { | |
4019 | static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; | |
4020 | ||
4021 | if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, | |
4022 | dt->delim->value.character.string, | |
44facdb7 FR |
4023 | io_kind_name (k), warn, |
4024 | &dt->delim->where)) | |
4025 | return false; | |
6f0f0b2e JD |
4026 | |
4027 | io_constraint (k == M_READ, | |
d06b3496 | 4028 | "DELIM= specifier at %L not allowed in a " |
6f0f0b2e | 4029 | "READ statement", &dt->delim->where); |
44facdb7 | 4030 | |
6f0f0b2e JD |
4031 | io_constraint (dt->format_label != &format_asterisk |
4032 | && dt->namelist == NULL, | |
d06b3496 | 4033 | "DELIM= specifier at %L must have FMT=*", |
6f0f0b2e JD |
4034 | &dt->delim->where); |
4035 | ||
4036 | io_constraint (unformatted && dt->namelist == NULL, | |
d06b3496 | 4037 | "DELIM= specifier at %L must be with FMT=* or " |
2f029c08 | 4038 | "NML= specifier", &dt->delim->where); |
6f0f0b2e JD |
4039 | } |
4040 | } | |
44facdb7 | 4041 | |
e0e85e06 PT |
4042 | if (dt->namelist) |
4043 | { | |
4044 | io_constraint (io_code && dt->namelist, | |
4045 | "NAMELIST cannot be followed by IO-list at %L", | |
4046 | &io_code->loc); | |
4047 | ||
4048 | io_constraint (dt->format_expr, | |
4049 | "IO spec-list cannot contain both NAMELIST group name " | |
f5c64803 | 4050 | "and format specification at %L", |
e0e85e06 PT |
4051 | &dt->format_expr->where); |
4052 | ||
4053 | io_constraint (dt->format_label, | |
4054 | "IO spec-list cannot contain both NAMELIST group name " | |
4055 | "and format label at %L", spec_end); | |
4056 | ||
4057 | io_constraint (dt->rec, | |
d06b3496 | 4058 | "NAMELIST IO is not allowed with a REC= specifier " |
f5c64803 | 4059 | "at %L", &dt->rec->where); |
e0e85e06 PT |
4060 | |
4061 | io_constraint (dt->advance, | |
d06b3496 | 4062 | "NAMELIST IO is not allowed with a ADVANCE= specifier " |
f5c64803 | 4063 | "at %L", &dt->advance->where); |
e0e85e06 PT |
4064 | } |
4065 | ||
4066 | if (dt->rec) | |
4067 | { | |
4068 | io_constraint (dt->end, | |
4069 | "An END tag is not allowed with a " | |
f5c64803 | 4070 | "REC= specifier at %L", &dt->end_where); |
e0e85e06 | 4071 | |
e0e85e06 | 4072 | io_constraint (dt->format_label == &format_asterisk, |
d06b3496 | 4073 | "FMT=* is not allowed with a REC= specifier " |
f5c64803 JD |
4074 | "at %L", spec_end); |
4075 | ||
4076 | io_constraint (dt->pos, | |
4077 | "POS= is not allowed with REC= specifier " | |
4078 | "at %L", &dt->pos->where); | |
e0e85e06 PT |
4079 | } |
4080 | ||
4081 | if (dt->advance) | |
4082 | { | |
e0e85e06 PT |
4083 | int not_yes, not_no; |
4084 | expr = dt->advance; | |
e0e85e06 PT |
4085 | |
4086 | io_constraint (dt->format_label == &format_asterisk, | |
4087 | "List directed format(*) is not allowed with a " | |
d06b3496 | 4088 | "ADVANCE= specifier at %L.", &expr->where); |
e0e85e06 | 4089 | |
6f0f0b2e | 4090 | io_constraint (unformatted, |
d06b3496 | 4091 | "the ADVANCE= specifier at %L must appear with an " |
b8ea6dbc PT |
4092 | "explicit format expression", &expr->where); |
4093 | ||
8370d5bc JJ |
4094 | if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) |
4095 | { | |
00660189 FXC |
4096 | const gfc_char_t *advance = expr->value.character.string; |
4097 | not_no = gfc_wide_strlen (advance) != 2 | |
4098 | || gfc_wide_strncasecmp (advance, "no", 2) != 0; | |
4099 | not_yes = gfc_wide_strlen (advance) != 3 | |
4100 | || gfc_wide_strncasecmp (advance, "yes", 3) != 0; | |
8370d5bc JJ |
4101 | } |
4102 | else | |
4103 | { | |
4104 | not_no = 0; | |
4105 | not_yes = 0; | |
4106 | } | |
e0e85e06 | 4107 | |
8370d5bc | 4108 | io_constraint (not_no && not_yes, |
d06b3496 | 4109 | "ADVANCE= specifier at %L must have value = " |
e0e85e06 PT |
4110 | "YES or NO.", &expr->where); |
4111 | ||
8370d5bc | 4112 | io_constraint (dt->size && not_no && k == M_READ, |
a4d9b221 | 4113 | "SIZE tag at %L requires an ADVANCE = %<NO%>", |
e0e85e06 PT |
4114 | &dt->size->where); |
4115 | ||
8370d5bc | 4116 | io_constraint (dt->eor && not_no && k == M_READ, |
a4d9b221 | 4117 | "EOR tag at %L requires an ADVANCE = %<NO%>", |
44facdb7 | 4118 | &dt->eor_where); |
e0e85e06 PT |
4119 | } |
4120 | ||
44facdb7 FR |
4121 | if (k != M_READ) |
4122 | { | |
4123 | io_constraint (dt->end, "END tag not allowed with output at %L", | |
4124 | &dt->end_where); | |
e0e85e06 | 4125 | |
44facdb7 FR |
4126 | io_constraint (dt->eor, "EOR tag not allowed with output at %L", |
4127 | &dt->eor_where); | |
4128 | ||
4129 | io_constraint (dt->blank, | |
4130 | "BLANK= specifier not allowed with output at %L", | |
4131 | &dt->blank->where); | |
4132 | ||
4133 | io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", | |
4134 | &dt->pad->where); | |
4135 | ||
4136 | io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", | |
4137 | &dt->size->where); | |
4138 | } | |
4139 | else | |
4140 | { | |
4141 | io_constraint (dt->size && dt->advance == NULL, | |
4142 | "SIZE tag at %L requires an ADVANCE tag", | |
4143 | &dt->size->where); | |
4144 | ||
4145 | io_constraint (dt->eor && dt->advance == NULL, | |
4146 | "EOR tag at %L requires an ADVANCE tag", | |
4147 | &dt->eor_where); | |
4148 | } | |
4149 | ||
4150 | return true; | |
e0e85e06 | 4151 | #undef io_constraint |
44facdb7 | 4152 | } |
e0e85e06 | 4153 | |
b251af97 | 4154 | |
6de9cd9a DN |
4155 | /* Match a READ, WRITE or PRINT statement. */ |
4156 | ||
4157 | static match | |
4158 | match_io (io_kind k) | |
4159 | { | |
4160 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
4161 | gfc_code *io_code; | |
4162 | gfc_symbol *sym; | |
8fc541d3 | 4163 | int comma_flag; |
6de9cd9a | 4164 | locus where; |
44facdb7 | 4165 | locus control; |
6de9cd9a DN |
4166 | gfc_dt *dt; |
4167 | match m; | |
4168 | ||
e0e85e06 | 4169 | where = gfc_current_locus; |
6de9cd9a | 4170 | comma_flag = 0; |
ece3f663 | 4171 | current_dt = dt = XCNEW (gfc_dt); |
ff2c6bbb SK |
4172 | m = gfc_match_char ('('); |
4173 | if (m == MATCH_NO) | |
6de9cd9a | 4174 | { |
7fd4d312 | 4175 | where = gfc_current_locus; |
08e1fe9e TS |
4176 | if (k == M_WRITE) |
4177 | goto syntax; | |
7fd4d312 | 4178 | else if (k == M_PRINT) |
7af8f00c | 4179 | { |
08e1fe9e | 4180 | /* Treat the non-standard case of PRINT namelist. */ |
8fc541d3 | 4181 | if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') |
7fd4d312 | 4182 | && gfc_match_name (name) == MATCH_YES) |
7af8f00c | 4183 | { |
7fd4d312 TS |
4184 | gfc_find_symbol (name, NULL, 1, &sym); |
4185 | if (sym && sym->attr.flavor == FL_NAMELIST) | |
08e1fe9e | 4186 | { |
524af0d6 JB |
4187 | if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at " |
4188 | "%C is an extension")) | |
7fd4d312 TS |
4189 | { |
4190 | m = MATCH_ERROR; | |
4191 | goto cleanup; | |
4192 | } | |
7fd4d312 TS |
4193 | |
4194 | dt->io_unit = default_unit (k); | |
4195 | dt->namelist = sym; | |
4196 | goto get_io_list; | |
08e1fe9e | 4197 | } |
7fd4d312 TS |
4198 | else |
4199 | gfc_current_locus = where; | |
08e1fe9e | 4200 | } |
474175e9 JD |
4201 | |
4202 | if (gfc_match_char ('*') == MATCH_YES | |
4203 | && gfc_match_char(',') == MATCH_YES) | |
4204 | { | |
4205 | locus where2 = gfc_current_locus; | |
4206 | if (gfc_match_eos () == MATCH_YES) | |
4207 | { | |
4208 | gfc_current_locus = where2; | |
4209 | gfc_error ("Comma after * at %C not allowed without I/O list"); | |
4210 | m = MATCH_ERROR; | |
4211 | goto cleanup; | |
4212 | } | |
4213 | else | |
4214 | gfc_current_locus = where; | |
4215 | } | |
4216 | else | |
4217 | gfc_current_locus = where; | |
7af8f00c PT |
4218 | } |
4219 | ||
0ff0dfbf | 4220 | if (gfc_current_form == FORM_FREE) |
7fd4d312 | 4221 | { |
8fc541d3 | 4222 | char c = gfc_peek_ascii_char (); |
7fd4d312 TS |
4223 | if (c != ' ' && c != '*' && c != '\'' && c != '"') |
4224 | { | |
4225 | m = MATCH_NO; | |
4226 | goto cleanup; | |
4227 | } | |
4228 | } | |
0ff0dfbf | 4229 | |
6de9cd9a DN |
4230 | m = match_dt_format (dt); |
4231 | if (m == MATCH_ERROR) | |
4232 | goto cleanup; | |
4233 | if (m == MATCH_NO) | |
4234 | goto syntax; | |
4235 | ||
4236 | comma_flag = 1; | |
4237 | dt->io_unit = default_unit (k); | |
4238 | goto get_io_list; | |
4239 | } | |
4d08533c TK |
4240 | else |
4241 | { | |
ff2c6bbb SK |
4242 | /* Before issuing an error for a malformed 'print (1,*)' type of |
4243 | error, check for a default-char-expr of the form ('(I0)'). */ | |
4731c9f0 JD |
4244 | if (m == MATCH_YES) |
4245 | { | |
4246 | control = gfc_current_locus; | |
4247 | if (k == M_PRINT) | |
4248 | { | |
4249 | /* Reset current locus to get the initial '(' in an expression. */ | |
4250 | gfc_current_locus = where; | |
4251 | dt->format_expr = NULL; | |
4252 | m = match_dt_format (dt); | |
ff2c6bbb | 4253 | |
4731c9f0 JD |
4254 | if (m == MATCH_ERROR) |
4255 | goto cleanup; | |
4256 | if (m == MATCH_NO || dt->format_expr == NULL) | |
4257 | goto syntax; | |
ff2c6bbb | 4258 | |
4731c9f0 JD |
4259 | comma_flag = 1; |
4260 | dt->io_unit = default_unit (k); | |
4261 | goto get_io_list; | |
4262 | } | |
4263 | if (k == M_READ) | |
4264 | { | |
bc720937 JD |
4265 | /* Commit any pending symbols now so that when we undo |
4266 | symbols later we wont lose them. */ | |
4267 | gfc_commit_symbols (); | |
4731c9f0 JD |
4268 | /* Reset current locus to get the initial '(' in an expression. */ |
4269 | gfc_current_locus = where; | |
4270 | dt->format_expr = NULL; | |
4271 | m = gfc_match_expr (&dt->format_expr); | |
4272 | if (m == MATCH_YES) | |
4273 | { | |
4274 | if (dt->format_expr | |
4275 | && dt->format_expr->ts.type == BT_CHARACTER) | |
4276 | { | |
4277 | comma_flag = 1; | |
4278 | dt->io_unit = default_unit (k); | |
4279 | goto get_io_list; | |
4280 | } | |
4281 | else | |
4282 | { | |
4283 | gfc_free_expr (dt->format_expr); | |
4284 | dt->format_expr = NULL; | |
4285 | gfc_current_locus = control; | |
4286 | } | |
4287 | } | |
4288 | else | |
4289 | { | |
4290 | gfc_clear_error (); | |
4291 | gfc_undo_symbols (); | |
4292 | gfc_free_expr (dt->format_expr); | |
4293 | dt->format_expr = NULL; | |
4294 | gfc_current_locus = control; | |
4295 | } | |
4296 | } | |
ff2c6bbb | 4297 | } |
4d08533c | 4298 | } |
6de9cd9a DN |
4299 | |
4300 | /* Match a control list */ | |
4301 | if (match_dt_element (k, dt) == MATCH_YES) | |
4302 | goto next; | |
4303 | if (match_dt_unit (k, dt) != MATCH_YES) | |
4304 | goto loop; | |
4305 | ||
4306 | if (gfc_match_char (')') == MATCH_YES) | |
4307 | goto get_io_list; | |
4308 | if (gfc_match_char (',') != MATCH_YES) | |
4309 | goto syntax; | |
4310 | ||
4311 | m = match_dt_element (k, dt); | |
4312 | if (m == MATCH_YES) | |
4313 | goto next; | |
4314 | if (m == MATCH_ERROR) | |
4315 | goto cleanup; | |
4316 | ||
4317 | m = match_dt_format (dt); | |
4318 | if (m == MATCH_YES) | |
4319 | goto next; | |
4320 | if (m == MATCH_ERROR) | |
4321 | goto cleanup; | |
4322 | ||
63645982 | 4323 | where = gfc_current_locus; |
6de9cd9a | 4324 | |
7fd4d312 TS |
4325 | m = gfc_match_name (name); |
4326 | if (m == MATCH_YES) | |
6de9cd9a | 4327 | { |
7fd4d312 TS |
4328 | gfc_find_symbol (name, NULL, 1, &sym); |
4329 | if (sym && sym->attr.flavor == FL_NAMELIST) | |
6de9cd9a | 4330 | { |
7fd4d312 TS |
4331 | dt->namelist = sym; |
4332 | if (k == M_READ && check_namelist (sym)) | |
4333 | { | |
4334 | m = MATCH_ERROR; | |
4335 | goto cleanup; | |
4336 | } | |
4337 | goto next; | |
6de9cd9a | 4338 | } |
6de9cd9a DN |
4339 | } |
4340 | ||
63645982 | 4341 | gfc_current_locus = where; |
6de9cd9a DN |
4342 | |
4343 | goto loop; /* No matches, try regular elements */ | |
4344 | ||
4345 | next: | |
4346 | if (gfc_match_char (')') == MATCH_YES) | |
4347 | goto get_io_list; | |
4348 | if (gfc_match_char (',') != MATCH_YES) | |
4349 | goto syntax; | |
4350 | ||
4351 | loop: | |
4352 | for (;;) | |
4353 | { | |
4354 | m = match_dt_element (k, dt); | |
4355 | if (m == MATCH_NO) | |
4356 | goto syntax; | |
4357 | if (m == MATCH_ERROR) | |
4358 | goto cleanup; | |
4359 | ||
4360 | if (gfc_match_char (')') == MATCH_YES) | |
4361 | break; | |
4362 | if (gfc_match_char (',') != MATCH_YES) | |
4363 | goto syntax; | |
4364 | } | |
4365 | ||
4366 | get_io_list: | |
e0e85e06 | 4367 | |
8e8dc060 DK |
4368 | /* Save the IO kind for later use. */ |
4369 | dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); | |
4370 | ||
ad7ee6f8 JD |
4371 | /* Optional leading comma (non-standard). We use a gfc_expr structure here |
4372 | to save the locus. This is used later when resolving transfer statements | |
4373 | that might have a format expression without unit number. */ | |
4374 | if (!comma_flag && gfc_match_char (',') == MATCH_YES) | |
8e8dc060 | 4375 | dt->extra_comma = dt->dt_io_kind; |
6de9cd9a DN |
4376 | |
4377 | io_code = NULL; | |
4378 | if (gfc_match_eos () != MATCH_YES) | |
4379 | { | |
4380 | if (comma_flag && gfc_match_char (',') != MATCH_YES) | |
4381 | { | |
4382 | gfc_error ("Expected comma in I/O list at %C"); | |
4383 | m = MATCH_ERROR; | |
4384 | goto cleanup; | |
4385 | } | |
4386 | ||
4387 | m = match_io_list (k, &io_code); | |
4388 | if (m == MATCH_ERROR) | |
4389 | goto cleanup; | |
4390 | if (m == MATCH_NO) | |
4391 | goto syntax; | |
4392 | } | |
4393 | ||
7ee4f6f3 | 4394 | /* See if we want to use defaults for missing exponents in real transfers |
88a8126a JB |
4395 | and other DEC runtime extensions. */ |
4396 | if (flag_dec_format_defaults) | |
7ee4f6f3 | 4397 | dt->dec_ext = 1; |
6869e9c6 | 4398 | |
44facdb7 FR |
4399 | /* Check the format string now. */ |
4400 | if (dt->format_expr | |
4401 | && (!gfc_simplify_expr (dt->format_expr, 0) | |
4402 | || !check_format_string (dt->format_expr, k == M_READ))) | |
4403 | return MATCH_ERROR; | |
6de9cd9a DN |
4404 | |
4405 | new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; | |
4406 | new_st.ext.dt = dt; | |
11e5274a | 4407 | new_st.block = gfc_get_code (new_st.op); |
5e805e44 | 4408 | new_st.block->next = io_code; |
6de9cd9a DN |
4409 | |
4410 | terminate_io (io_code); | |
4411 | ||
4412 | return MATCH_YES; | |
4413 | ||
4414 | syntax: | |
4415 | gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); | |
4416 | m = MATCH_ERROR; | |
4417 | ||
4418 | cleanup: | |
4419 | gfc_free_dt (dt); | |
4420 | return m; | |
4421 | } | |
4422 | ||
4423 | ||
4424 | match | |
4425 | gfc_match_read (void) | |
4426 | { | |
4427 | return match_io (M_READ); | |
4428 | } | |
4429 | ||
6f0f0b2e | 4430 | |
6de9cd9a DN |
4431 | match |
4432 | gfc_match_write (void) | |
4433 | { | |
4434 | return match_io (M_WRITE); | |
4435 | } | |
4436 | ||
6f0f0b2e | 4437 | |
6de9cd9a DN |
4438 | match |
4439 | gfc_match_print (void) | |
4440 | { | |
4441 | match m; | |
4442 | ||
4443 | m = match_io (M_PRINT); | |
4444 | if (m != MATCH_YES) | |
4445 | return m; | |
4446 | ||
4447 | if (gfc_pure (NULL)) | |
4448 | { | |
4449 | gfc_error ("PRINT statement at %C not allowed within PURE procedure"); | |
4450 | return MATCH_ERROR; | |
4451 | } | |
4452 | ||
ccd7751b | 4453 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 4454 | |
6de9cd9a DN |
4455 | return MATCH_YES; |
4456 | } | |
4457 | ||
4458 | ||
4459 | /* Free a gfc_inquire structure. */ | |
4460 | ||
4461 | void | |
b251af97 | 4462 | gfc_free_inquire (gfc_inquire *inquire) |
6de9cd9a DN |
4463 | { |
4464 | ||
4465 | if (inquire == NULL) | |
4466 | return; | |
4467 | ||
4468 | gfc_free_expr (inquire->unit); | |
4469 | gfc_free_expr (inquire->file); | |
7aba8abe | 4470 | gfc_free_expr (inquire->iomsg); |
6de9cd9a DN |
4471 | gfc_free_expr (inquire->iostat); |
4472 | gfc_free_expr (inquire->exist); | |
4473 | gfc_free_expr (inquire->opened); | |
4474 | gfc_free_expr (inquire->number); | |
4475 | gfc_free_expr (inquire->named); | |
4476 | gfc_free_expr (inquire->name); | |
4477 | gfc_free_expr (inquire->access); | |
4478 | gfc_free_expr (inquire->sequential); | |
4479 | gfc_free_expr (inquire->direct); | |
4480 | gfc_free_expr (inquire->form); | |
4481 | gfc_free_expr (inquire->formatted); | |
4482 | gfc_free_expr (inquire->unformatted); | |
4483 | gfc_free_expr (inquire->recl); | |
4484 | gfc_free_expr (inquire->nextrec); | |
4485 | gfc_free_expr (inquire->blank); | |
4486 | gfc_free_expr (inquire->position); | |
4487 | gfc_free_expr (inquire->action); | |
4488 | gfc_free_expr (inquire->read); | |
4489 | gfc_free_expr (inquire->write); | |
4490 | gfc_free_expr (inquire->readwrite); | |
4491 | gfc_free_expr (inquire->delim); | |
d06b3496 | 4492 | gfc_free_expr (inquire->encoding); |
6de9cd9a DN |
4493 | gfc_free_expr (inquire->pad); |
4494 | gfc_free_expr (inquire->iolength); | |
181c9f4a | 4495 | gfc_free_expr (inquire->convert); |
014ec6ee | 4496 | gfc_free_expr (inquire->strm_pos); |
d06b3496 | 4497 | gfc_free_expr (inquire->asynchronous); |
e1456843 | 4498 | gfc_free_expr (inquire->decimal); |
d06b3496 JD |
4499 | gfc_free_expr (inquire->pending); |
4500 | gfc_free_expr (inquire->id); | |
4501 | gfc_free_expr (inquire->sign); | |
e1456843 | 4502 | gfc_free_expr (inquire->size); |
d06b3496 | 4503 | gfc_free_expr (inquire->round); |
0ef33d44 FR |
4504 | gfc_free_expr (inquire->share); |
4505 | gfc_free_expr (inquire->cc); | |
cede9502 | 4506 | free (inquire); |
6de9cd9a DN |
4507 | } |
4508 | ||
4509 | ||
4510 | /* Match an element of an INQUIRE statement. */ | |
4511 | ||
4512 | #define RETM if (m != MATCH_NO) return m; | |
4513 | ||
4514 | static match | |
b251af97 | 4515 | match_inquire_element (gfc_inquire *inquire) |
6de9cd9a DN |
4516 | { |
4517 | match m; | |
4518 | ||
4519 | m = match_etag (&tag_unit, &inquire->unit); | |
4520 | RETM m = match_etag (&tag_file, &inquire->file); | |
4521 | RETM m = match_ltag (&tag_err, &inquire->err); | |
fd5cabb2 | 4522 | RETM m = match_etag (&tag_iomsg, &inquire->iomsg); |
c9583ed2 | 4523 | RETM m = match_out_tag (&tag_iostat, &inquire->iostat); |
6de9cd9a DN |
4524 | RETM m = match_vtag (&tag_exist, &inquire->exist); |
4525 | RETM m = match_vtag (&tag_opened, &inquire->opened); | |
4526 | RETM m = match_vtag (&tag_named, &inquire->named); | |
4527 | RETM m = match_vtag (&tag_name, &inquire->name); | |
c9583ed2 | 4528 | RETM m = match_out_tag (&tag_number, &inquire->number); |
6de9cd9a DN |
4529 | RETM m = match_vtag (&tag_s_access, &inquire->access); |
4530 | RETM m = match_vtag (&tag_sequential, &inquire->sequential); | |
4531 | RETM m = match_vtag (&tag_direct, &inquire->direct); | |
4532 | RETM m = match_vtag (&tag_s_form, &inquire->form); | |
4533 | RETM m = match_vtag (&tag_formatted, &inquire->formatted); | |
4534 | RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); | |
c9583ed2 TS |
4535 | RETM m = match_out_tag (&tag_s_recl, &inquire->recl); |
4536 | RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec); | |
6de9cd9a DN |
4537 | RETM m = match_vtag (&tag_s_blank, &inquire->blank); |
4538 | RETM m = match_vtag (&tag_s_position, &inquire->position); | |
4539 | RETM m = match_vtag (&tag_s_action, &inquire->action); | |
4540 | RETM m = match_vtag (&tag_read, &inquire->read); | |
4541 | RETM m = match_vtag (&tag_write, &inquire->write); | |
4542 | RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); | |
d06b3496 | 4543 | RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); |
6de9cd9a | 4544 | RETM m = match_vtag (&tag_s_delim, &inquire->delim); |
d06b3496 | 4545 | RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); |
92867546 | 4546 | RETM m = match_out_tag (&tag_size, &inquire->size); |
d06b3496 JD |
4547 | RETM m = match_vtag (&tag_s_encoding, &inquire->encoding); |
4548 | RETM m = match_vtag (&tag_s_round, &inquire->round); | |
4549 | RETM m = match_vtag (&tag_s_sign, &inquire->sign); | |
6de9cd9a | 4550 | RETM m = match_vtag (&tag_s_pad, &inquire->pad); |
92867546 | 4551 | RETM m = match_out_tag (&tag_iolength, &inquire->iolength); |
181c9f4a | 4552 | RETM m = match_vtag (&tag_convert, &inquire->convert); |
014ec6ee | 4553 | RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos); |
d06b3496 JD |
4554 | RETM m = match_vtag (&tag_pending, &inquire->pending); |
4555 | RETM m = match_vtag (&tag_id, &inquire->id); | |
93e8af19 | 4556 | RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream); |
0ef33d44 FR |
4557 | RETM m = match_dec_vtag (&tag_v_share, &inquire->share); |
4558 | RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc); | |
6de9cd9a DN |
4559 | RETM return MATCH_NO; |
4560 | } | |
4561 | ||
4562 | #undef RETM | |
4563 | ||
4564 | ||
4565 | match | |
4566 | gfc_match_inquire (void) | |
4567 | { | |
4568 | gfc_inquire *inquire; | |
4569 | gfc_code *code; | |
4570 | match m; | |
44998b65 | 4571 | locus loc; |
6de9cd9a DN |
4572 | |
4573 | m = gfc_match_char ('('); | |
4574 | if (m == MATCH_NO) | |
4575 | return m; | |
4576 | ||
ece3f663 | 4577 | inquire = XCNEW (gfc_inquire); |
6de9cd9a | 4578 | |
44998b65 JB |
4579 | loc = gfc_current_locus; |
4580 | ||
6de9cd9a DN |
4581 | m = match_inquire_element (inquire); |
4582 | if (m == MATCH_ERROR) | |
4583 | goto cleanup; | |
4584 | if (m == MATCH_NO) | |
4585 | { | |
4586 | m = gfc_match_expr (&inquire->unit); | |
4587 | if (m == MATCH_ERROR) | |
4588 | goto cleanup; | |
4589 | if (m == MATCH_NO) | |
4590 | goto syntax; | |
4591 | } | |
4592 | ||
4593 | /* See if we have the IOLENGTH form of the inquire statement. */ | |
4594 | if (inquire->iolength != NULL) | |
4595 | { | |
4596 | if (gfc_match_char (')') != MATCH_YES) | |
4597 | goto syntax; | |
4598 | ||
4599 | m = match_io_list (M_INQUIRE, &code); | |
4600 | if (m == MATCH_ERROR) | |
4601 | goto cleanup; | |
4602 | if (m == MATCH_NO) | |
4603 | goto syntax; | |
4604 | ||
84e33251 SK |
4605 | for (gfc_code *c = code; c; c = c->next) |
4606 | if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION | |
4607 | && c->expr1->symtree && c->expr1->symtree->n.sym->attr.function | |
4608 | && !c->expr1->symtree->n.sym->attr.external | |
4609 | && strcmp (c->expr1->symtree->name, "null") == 0) | |
4610 | { | |
4611 | gfc_error ("NULL() near %L cannot appear in INQUIRE statement", | |
4612 | &c->expr1->where); | |
4613 | goto cleanup; | |
4614 | } | |
4615 | ||
6de9cd9a | 4616 | new_st.op = EXEC_IOLENGTH; |
a513927a | 4617 | new_st.expr1 = inquire->iolength; |
8750f9cd | 4618 | new_st.ext.inquire = inquire; |
6de9cd9a DN |
4619 | |
4620 | if (gfc_pure (NULL)) | |
4621 | { | |
4622 | gfc_free_statements (code); | |
4623 | gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); | |
4624 | return MATCH_ERROR; | |
4625 | } | |
4626 | ||
ccd7751b | 4627 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 4628 | |
11e5274a | 4629 | new_st.block = gfc_get_code (EXEC_IOLENGTH); |
5e805e44 JJ |
4630 | terminate_io (code); |
4631 | new_st.block->next = code; | |
6de9cd9a DN |
4632 | return MATCH_YES; |
4633 | } | |
4634 | ||
4635 | /* At this point, we have the non-IOLENGTH inquire statement. */ | |
4636 | for (;;) | |
4637 | { | |
4638 | if (gfc_match_char (')') == MATCH_YES) | |
4639 | break; | |
4640 | if (gfc_match_char (',') != MATCH_YES) | |
4641 | goto syntax; | |
4642 | ||
4643 | m = match_inquire_element (inquire); | |
4644 | if (m == MATCH_ERROR) | |
4645 | goto cleanup; | |
4646 | if (m == MATCH_NO) | |
4647 | goto syntax; | |
4648 | ||
4649 | if (inquire->iolength != NULL) | |
4650 | { | |
4651 | gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C"); | |
4652 | goto cleanup; | |
4653 | } | |
4654 | } | |
4655 | ||
4656 | if (gfc_match_eos () != MATCH_YES) | |
4657 | goto syntax; | |
4658 | ||
44998b65 JB |
4659 | if (inquire->unit != NULL && inquire->file != NULL) |
4660 | { | |
b251af97 SK |
4661 | gfc_error ("INQUIRE statement at %L cannot contain both FILE and " |
4662 | "UNIT specifiers", &loc); | |
44998b65 JB |
4663 | goto cleanup; |
4664 | } | |
4665 | ||
4666 | if (inquire->unit == NULL && inquire->file == NULL) | |
4667 | { | |
b251af97 SK |
4668 | gfc_error ("INQUIRE statement at %L requires either FILE or " |
4669 | "UNIT specifier", &loc); | |
44998b65 JB |
4670 | goto cleanup; |
4671 | } | |
4672 | ||
2da229cb JD |
4673 | if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT |
4674 | && inquire->unit->ts.type == BT_INTEGER | |
4a8d4422 JD |
4675 | && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4) |
4676 | || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT))) | |
2da229cb | 4677 | { |
67914693 | 4678 | gfc_error ("UNIT number in INQUIRE statement at %L cannot " |
4a8d4422 | 4679 | "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer)); |
2da229cb JD |
4680 | goto cleanup; |
4681 | } | |
4682 | ||
6de9cd9a DN |
4683 | if (gfc_pure (NULL)) |
4684 | { | |
4685 | gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); | |
4686 | goto cleanup; | |
4687 | } | |
f1f39033 | 4688 | |
ccd7751b | 4689 | gfc_unset_implicit_pure (NULL); |
d06b3496 JD |
4690 | |
4691 | if (inquire->id != NULL && inquire->pending == NULL) | |
4692 | { | |
4693 | gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with " | |
4694 | "the ID= specifier", &loc); | |
4695 | goto cleanup; | |
4696 | } | |
6de9cd9a DN |
4697 | |
4698 | new_st.op = EXEC_INQUIRE; | |
4699 | new_st.ext.inquire = inquire; | |
4700 | return MATCH_YES; | |
4701 | ||
4702 | syntax: | |
4703 | gfc_syntax_error (ST_INQUIRE); | |
4704 | ||
4705 | cleanup: | |
4706 | gfc_free_inquire (inquire); | |
4707 | return MATCH_ERROR; | |
4708 | } | |
4709 | ||
4710 | ||
4711 | /* Resolve everything in a gfc_inquire structure. */ | |
4712 | ||
524af0d6 | 4713 | bool |
b251af97 | 4714 | gfc_resolve_inquire (gfc_inquire *inquire) |
6de9cd9a | 4715 | { |
6de9cd9a DN |
4716 | RESOLVE_TAG (&tag_unit, inquire->unit); |
4717 | RESOLVE_TAG (&tag_file, inquire->file); | |
d06b3496 | 4718 | RESOLVE_TAG (&tag_id, inquire->id); |
6de9cd9a | 4719 | |
8e8dc060 DK |
4720 | /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition |
4721 | contexts. Thus, use an extended RESOLVE_TAG macro for that. */ | |
4722 | #define INQUIRE_RESOLVE_TAG(tag, expr) \ | |
4723 | RESOLVE_TAG (tag, expr); \ | |
4724 | if (expr) \ | |
4725 | { \ | |
4726 | char context[64]; \ | |
4727 | sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \ | |
57bf28ea | 4728 | if (gfc_check_vardef_context ((expr), false, false, false, \ |
524af0d6 JB |
4729 | context) == false) \ |
4730 | return false; \ | |
8e8dc060 DK |
4731 | } |
4732 | INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg); | |
4733 | INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat); | |
4734 | INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist); | |
4735 | INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened); | |
4736 | INQUIRE_RESOLVE_TAG (&tag_number, inquire->number); | |
4737 | INQUIRE_RESOLVE_TAG (&tag_named, inquire->named); | |
4738 | INQUIRE_RESOLVE_TAG (&tag_name, inquire->name); | |
4739 | INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access); | |
4740 | INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential); | |
4741 | INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct); | |
4742 | INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form); | |
4743 | INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted); | |
4744 | INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted); | |
4745 | INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl); | |
4746 | INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec); | |
4747 | INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank); | |
4748 | INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position); | |
4749 | INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action); | |
4750 | INQUIRE_RESOLVE_TAG (&tag_read, inquire->read); | |
4751 | INQUIRE_RESOLVE_TAG (&tag_write, inquire->write); | |
4752 | INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite); | |
4753 | INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim); | |
4754 | INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad); | |
4755 | INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding); | |
4756 | INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); | |
4757 | INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength); | |
4758 | INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert); | |
4759 | INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); | |
4760 | INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous); | |
4761 | INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign); | |
4762 | INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); | |
4763 | INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending); | |
4764 | INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); | |
75933b07 | 4765 | INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal); |
93e8af19 | 4766 | INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream); |
0ef33d44 FR |
4767 | INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share); |
4768 | INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc); | |
8e8dc060 DK |
4769 | #undef INQUIRE_RESOLVE_TAG |
4770 | ||
524af0d6 JB |
4771 | if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET)) |
4772 | return false; | |
6de9cd9a | 4773 | |
524af0d6 | 4774 | return true; |
6de9cd9a | 4775 | } |
6f0f0b2e JD |
4776 | |
4777 | ||
4778 | void | |
4779 | gfc_free_wait (gfc_wait *wait) | |
4780 | { | |
4781 | if (wait == NULL) | |
4782 | return; | |
4783 | ||
4784 | gfc_free_expr (wait->unit); | |
4785 | gfc_free_expr (wait->iostat); | |
4786 | gfc_free_expr (wait->iomsg); | |
4787 | gfc_free_expr (wait->id); | |
efb63364 | 4788 | free (wait); |
6f0f0b2e JD |
4789 | } |
4790 | ||
4791 | ||
524af0d6 | 4792 | bool |
6f0f0b2e JD |
4793 | gfc_resolve_wait (gfc_wait *wait) |
4794 | { | |
4795 | RESOLVE_TAG (&tag_unit, wait->unit); | |
4796 | RESOLVE_TAG (&tag_iomsg, wait->iomsg); | |
4797 | RESOLVE_TAG (&tag_iostat, wait->iostat); | |
4798 | RESOLVE_TAG (&tag_id, wait->id); | |
4799 | ||
524af0d6 JB |
4800 | if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET)) |
4801 | return false; | |
6f0f0b2e | 4802 | |
524af0d6 JB |
4803 | if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET)) |
4804 | return false; | |
6f0f0b2e | 4805 | |
524af0d6 | 4806 | return true; |
6f0f0b2e JD |
4807 | } |
4808 | ||
4809 | /* Match an element of a WAIT statement. */ | |
4810 | ||
4811 | #define RETM if (m != MATCH_NO) return m; | |
4812 | ||
4813 | static match | |
4814 | match_wait_element (gfc_wait *wait) | |
4815 | { | |
4816 | match m; | |
4817 | ||
4818 | m = match_etag (&tag_unit, &wait->unit); | |
4819 | RETM m = match_ltag (&tag_err, &wait->err); | |
4f8d1d32 TK |
4820 | RETM m = match_ltag (&tag_end, &wait->end); |
4821 | RETM m = match_ltag (&tag_eor, &wait->eor); | |
fd5cabb2 | 4822 | RETM m = match_etag (&tag_iomsg, &wait->iomsg); |
6f0f0b2e JD |
4823 | RETM m = match_out_tag (&tag_iostat, &wait->iostat); |
4824 | RETM m = match_etag (&tag_id, &wait->id); | |
4825 | RETM return MATCH_NO; | |
4826 | } | |
4827 | ||
4828 | #undef RETM | |
4829 | ||
4830 | ||
4831 | match | |
4832 | gfc_match_wait (void) | |
4833 | { | |
4834 | gfc_wait *wait; | |
4835 | match m; | |
6f0f0b2e JD |
4836 | |
4837 | m = gfc_match_char ('('); | |
4838 | if (m == MATCH_NO) | |
4839 | return m; | |
4840 | ||
ece3f663 | 4841 | wait = XCNEW (gfc_wait); |
6f0f0b2e | 4842 | |
6f0f0b2e JD |
4843 | m = match_wait_element (wait); |
4844 | if (m == MATCH_ERROR) | |
4845 | goto cleanup; | |
4846 | if (m == MATCH_NO) | |
4847 | { | |
4848 | m = gfc_match_expr (&wait->unit); | |
4849 | if (m == MATCH_ERROR) | |
4850 | goto cleanup; | |
4851 | if (m == MATCH_NO) | |
4852 | goto syntax; | |
4853 | } | |
4854 | ||
4855 | for (;;) | |
4856 | { | |
4857 | if (gfc_match_char (')') == MATCH_YES) | |
4858 | break; | |
4859 | if (gfc_match_char (',') != MATCH_YES) | |
4860 | goto syntax; | |
4861 | ||
4862 | m = match_wait_element (wait); | |
4863 | if (m == MATCH_ERROR) | |
4864 | goto cleanup; | |
4865 | if (m == MATCH_NO) | |
4866 | goto syntax; | |
4867 | } | |
4868 | ||
524af0d6 JB |
4869 | if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C " |
4870 | "not allowed in Fortran 95")) | |
6f0f0b2e JD |
4871 | goto cleanup; |
4872 | ||
4873 | if (gfc_pure (NULL)) | |
4874 | { | |
4875 | gfc_error ("WAIT statement not allowed in PURE procedure at %C"); | |
4876 | goto cleanup; | |
4877 | } | |
4878 | ||
ccd7751b | 4879 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 4880 | |
6f0f0b2e JD |
4881 | new_st.op = EXEC_WAIT; |
4882 | new_st.ext.wait = wait; | |
4883 | ||
4884 | return MATCH_YES; | |
4885 | ||
4886 | syntax: | |
4887 | gfc_syntax_error (ST_WAIT); | |
4888 | ||
4889 | cleanup: | |
4890 | gfc_free_wait (wait); | |
4891 | return MATCH_ERROR; | |
4892 | } |