]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Deal with I/O statements & related stuff. |
7adcbafe | 2 | Copyright (C) 2000-2022 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 | { |
ebf9b6c1 | 1765 | if (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS |
f527b823 | 1766 | || e->ts.type == BT_VOID || e->ts.type == BT_UNKNOWN) |
ebf9b6c1 TB |
1767 | { |
1768 | gfc_error ("Non-character non-Hollerith in FORMAT tag at %L", | |
1769 | &e->where); | |
1770 | return false; | |
1771 | } | |
524af0d6 JB |
1772 | if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag " |
1773 | "at %L", &e->where)) | |
1774 | return false; | |
7e279142 JJ |
1775 | |
1776 | if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) | |
1777 | { | |
1778 | gfc_error ("Non-character assumed shape 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->as->type == AS_ASSUMED_SIZE) | |
1784 | { | |
1785 | gfc_error ("Non-character assumed size array element in FORMAT" | |
1786 | " tag at %L", &e->where); | |
524af0d6 | 1787 | return false; |
7e279142 JJ |
1788 | } |
1789 | ||
1790 | if (e->rank == 0 && e->symtree->n.sym->attr.pointer) | |
1791 | { | |
1792 | gfc_error ("Non-character pointer array element in FORMAT tag at %L", | |
1793 | &e->where); | |
524af0d6 | 1794 | return false; |
7e279142 | 1795 | } |
f25bf34f | 1796 | } |
418a78fa | 1797 | |
524af0d6 | 1798 | return true; |
f25bf34f | 1799 | } |
418a78fa | 1800 | |
e0e85e06 | 1801 | |
f25bf34f | 1802 | /* Do expression resolution and type-checking on an expression tag. */ |
418a78fa | 1803 | |
524af0d6 | 1804 | static bool |
f25bf34f TS |
1805 | resolve_tag (const io_tag *tag, gfc_expr *e) |
1806 | { | |
1807 | if (e == NULL) | |
524af0d6 | 1808 | return true; |
f25bf34f | 1809 | |
524af0d6 JB |
1810 | if (!gfc_resolve_expr (e)) |
1811 | return false; | |
f25bf34f TS |
1812 | |
1813 | if (tag == &tag_format) | |
1814 | return resolve_tag_format (e); | |
1815 | ||
1816 | if (e->ts.type != tag->type) | |
1817 | { | |
1818 | gfc_error ("%s tag at %L must be of type %s", tag->name, | |
1819 | &e->where, gfc_basic_typename (tag->type)); | |
524af0d6 | 1820 | return false; |
6de9cd9a DN |
1821 | } |
1822 | ||
75933b07 TB |
1823 | if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind) |
1824 | { | |
1825 | gfc_error ("%s tag at %L must be a character string of default kind", | |
1826 | tag->name, &e->where); | |
524af0d6 | 1827 | return false; |
75933b07 TB |
1828 | } |
1829 | ||
f25bf34f TS |
1830 | if (e->rank != 0) |
1831 | { | |
1832 | gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); | |
524af0d6 | 1833 | return false; |
f25bf34f TS |
1834 | } |
1835 | ||
1836 | if (tag == &tag_iomsg) | |
1837 | { | |
524af0d6 JB |
1838 | if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where)) |
1839 | return false; | |
f25bf34f TS |
1840 | } |
1841 | ||
72b572cb FXC |
1842 | if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength |
1843 | || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl) | |
f25bf34f TS |
1844 | && e->ts.kind != gfc_default_integer_kind) |
1845 | { | |
524af0d6 JB |
1846 | if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " |
1847 | "INTEGER in %s tag at %L", tag->name, &e->where)) | |
1848 | return false; | |
f25bf34f TS |
1849 | } |
1850 | ||
72b572cb FXC |
1851 | if (e->ts.kind != gfc_default_logical_kind && |
1852 | (tag == &tag_exist || tag == &tag_named || tag == &tag_opened | |
1853 | || tag == &tag_pending)) | |
92336ae1 | 1854 | { |
72b572cb | 1855 | if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind " |
524af0d6 JB |
1856 | "in %s tag at %L", tag->name, &e->where)) |
1857 | return false; | |
92336ae1 SK |
1858 | } |
1859 | ||
8e8dc060 DK |
1860 | if (tag == &tag_newunit) |
1861 | { | |
524af0d6 JB |
1862 | if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L", |
1863 | &e->where)) | |
1864 | return false; | |
8e8dc060 DK |
1865 | } |
1866 | ||
1867 | /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */ | |
1868 | if (tag == &tag_newunit || tag == &tag_iostat | |
1869 | || tag == &tag_size || tag == &tag_iomsg) | |
1870 | { | |
1871 | char context[64]; | |
1872 | ||
1873 | sprintf (context, _("%s tag"), tag->name); | |
524af0d6 JB |
1874 | if (!gfc_check_vardef_context (e, false, false, false, context)) |
1875 | return false; | |
8e8dc060 DK |
1876 | } |
1877 | ||
f25bf34f TS |
1878 | if (tag == &tag_convert) |
1879 | { | |
524af0d6 JB |
1880 | if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where)) |
1881 | return false; | |
f25bf34f | 1882 | } |
8e8dc060 | 1883 | |
524af0d6 | 1884 | return true; |
6de9cd9a DN |
1885 | } |
1886 | ||
1887 | ||
1888 | /* Match a single tag of an OPEN statement. */ | |
1889 | ||
1890 | static match | |
b251af97 | 1891 | match_open_element (gfc_open *open) |
6de9cd9a DN |
1892 | { |
1893 | match m; | |
1894 | ||
d06b3496 | 1895 | m = match_etag (&tag_e_async, &open->asynchronous); |
6f0f0b2e JD |
1896 | if (m != MATCH_NO) |
1897 | return m; | |
6de9cd9a | 1898 | m = match_etag (&tag_unit, &open->unit); |
7aba8abe TK |
1899 | if (m != MATCH_NO) |
1900 | return m; | |
fd5cabb2 | 1901 | m = match_etag (&tag_iomsg, &open->iomsg); |
6de9cd9a DN |
1902 | if (m != MATCH_NO) |
1903 | return m; | |
c9583ed2 | 1904 | m = match_out_tag (&tag_iostat, &open->iostat); |
6de9cd9a DN |
1905 | if (m != MATCH_NO) |
1906 | return m; | |
1907 | m = match_etag (&tag_file, &open->file); | |
1908 | if (m != MATCH_NO) | |
1909 | return m; | |
1910 | m = match_etag (&tag_status, &open->status); | |
1911 | if (m != MATCH_NO) | |
1912 | return m; | |
1913 | m = match_etag (&tag_e_access, &open->access); | |
1914 | if (m != MATCH_NO) | |
1915 | return m; | |
1916 | m = match_etag (&tag_e_form, &open->form); | |
1917 | if (m != MATCH_NO) | |
1918 | return m; | |
1919 | m = match_etag (&tag_e_recl, &open->recl); | |
1920 | if (m != MATCH_NO) | |
1921 | return m; | |
1922 | m = match_etag (&tag_e_blank, &open->blank); | |
1923 | if (m != MATCH_NO) | |
1924 | return m; | |
1925 | m = match_etag (&tag_e_position, &open->position); | |
1926 | if (m != MATCH_NO) | |
1927 | return m; | |
1928 | m = match_etag (&tag_e_action, &open->action); | |
1929 | if (m != MATCH_NO) | |
1930 | return m; | |
1931 | m = match_etag (&tag_e_delim, &open->delim); | |
1932 | if (m != MATCH_NO) | |
1933 | return m; | |
1934 | m = match_etag (&tag_e_pad, &open->pad); | |
6f0f0b2e JD |
1935 | if (m != MATCH_NO) |
1936 | return m; | |
1937 | m = match_etag (&tag_e_decimal, &open->decimal); | |
1938 | if (m != MATCH_NO) | |
1939 | return m; | |
1940 | m = match_etag (&tag_e_encoding, &open->encoding); | |
1941 | if (m != MATCH_NO) | |
1942 | return m; | |
1943 | m = match_etag (&tag_e_round, &open->round); | |
1944 | if (m != MATCH_NO) | |
1945 | return m; | |
1946 | m = match_etag (&tag_e_sign, &open->sign); | |
6de9cd9a DN |
1947 | if (m != MATCH_NO) |
1948 | return m; | |
1949 | m = match_ltag (&tag_err, &open->err); | |
181c9f4a TK |
1950 | if (m != MATCH_NO) |
1951 | return m; | |
1952 | m = match_etag (&tag_convert, &open->convert); | |
9ad55c33 JD |
1953 | if (m != MATCH_NO) |
1954 | return m; | |
1955 | m = match_out_tag (&tag_newunit, &open->newunit); | |
6de9cd9a DN |
1956 | if (m != MATCH_NO) |
1957 | return m; | |
1958 | ||
0ef33d44 FR |
1959 | /* The following are extensions enabled with -fdec. */ |
1960 | m = match_dec_etag (&tag_e_share, &open->share); | |
1961 | if (m != MATCH_NO) | |
1962 | return m; | |
1963 | m = match_dec_etag (&tag_cc, &open->cc); | |
1964 | if (m != MATCH_NO) | |
1965 | return m; | |
1966 | m = match_dec_ftag (&tag_readonly, open); | |
1967 | if (m != MATCH_NO) | |
1968 | return m; | |
1969 | m = match_dec_ftag (&tag_shared, open); | |
1970 | if (m != MATCH_NO) | |
1971 | return m; | |
1972 | m = match_dec_ftag (&tag_noshared, open); | |
1973 | if (m != MATCH_NO) | |
1974 | return m; | |
1975 | ||
6de9cd9a DN |
1976 | return MATCH_NO; |
1977 | } | |
1978 | ||
1979 | ||
1980 | /* Free the gfc_open structure and all the expressions it contains. */ | |
1981 | ||
1982 | void | |
b251af97 | 1983 | gfc_free_open (gfc_open *open) |
6de9cd9a | 1984 | { |
6de9cd9a DN |
1985 | if (open == NULL) |
1986 | return; | |
1987 | ||
1988 | gfc_free_expr (open->unit); | |
7aba8abe | 1989 | gfc_free_expr (open->iomsg); |
6de9cd9a DN |
1990 | gfc_free_expr (open->iostat); |
1991 | gfc_free_expr (open->file); | |
1992 | gfc_free_expr (open->status); | |
1993 | gfc_free_expr (open->access); | |
1994 | gfc_free_expr (open->form); | |
1995 | gfc_free_expr (open->recl); | |
1996 | gfc_free_expr (open->blank); | |
1997 | gfc_free_expr (open->position); | |
1998 | gfc_free_expr (open->action); | |
1999 | gfc_free_expr (open->delim); | |
2000 | gfc_free_expr (open->pad); | |
6f0f0b2e JD |
2001 | gfc_free_expr (open->decimal); |
2002 | gfc_free_expr (open->encoding); | |
2003 | gfc_free_expr (open->round); | |
2004 | gfc_free_expr (open->sign); | |
181c9f4a | 2005 | gfc_free_expr (open->convert); |
6f0f0b2e | 2006 | gfc_free_expr (open->asynchronous); |
9ad55c33 | 2007 | gfc_free_expr (open->newunit); |
0ef33d44 FR |
2008 | gfc_free_expr (open->share); |
2009 | gfc_free_expr (open->cc); | |
cede9502 | 2010 | free (open); |
6de9cd9a DN |
2011 | } |
2012 | ||
2013 | ||
44facdb7 FR |
2014 | static int |
2015 | compare_to_allowed_values (const char *specifier, const char *allowed[], | |
2016 | const char *allowed_f2003[], | |
2017 | const char *allowed_gnu[], gfc_char_t *value, | |
2018 | const char *statement, bool warn, locus *where, | |
2019 | int *num = NULL); | |
2020 | ||
2021 | ||
2022 | static bool | |
2023 | check_open_constraints (gfc_open *open, locus *where); | |
2024 | ||
6de9cd9a DN |
2025 | /* Resolve everything in a gfc_open structure. */ |
2026 | ||
524af0d6 | 2027 | bool |
44facdb7 | 2028 | gfc_resolve_open (gfc_open *open, locus *where) |
6de9cd9a | 2029 | { |
6de9cd9a | 2030 | RESOLVE_TAG (&tag_unit, open->unit); |
7aba8abe | 2031 | RESOLVE_TAG (&tag_iomsg, open->iomsg); |
6de9cd9a DN |
2032 | RESOLVE_TAG (&tag_iostat, open->iostat); |
2033 | RESOLVE_TAG (&tag_file, open->file); | |
2034 | RESOLVE_TAG (&tag_status, open->status); | |
1e90e92f | 2035 | RESOLVE_TAG (&tag_e_access, open->access); |
6de9cd9a DN |
2036 | RESOLVE_TAG (&tag_e_form, open->form); |
2037 | RESOLVE_TAG (&tag_e_recl, open->recl); | |
6de9cd9a DN |
2038 | RESOLVE_TAG (&tag_e_blank, open->blank); |
2039 | RESOLVE_TAG (&tag_e_position, open->position); | |
2040 | RESOLVE_TAG (&tag_e_action, open->action); | |
2041 | RESOLVE_TAG (&tag_e_delim, open->delim); | |
2042 | RESOLVE_TAG (&tag_e_pad, open->pad); | |
6f0f0b2e JD |
2043 | RESOLVE_TAG (&tag_e_decimal, open->decimal); |
2044 | RESOLVE_TAG (&tag_e_encoding, open->encoding); | |
d06b3496 | 2045 | RESOLVE_TAG (&tag_e_async, open->asynchronous); |
6f0f0b2e JD |
2046 | RESOLVE_TAG (&tag_e_round, open->round); |
2047 | RESOLVE_TAG (&tag_e_sign, open->sign); | |
181c9f4a | 2048 | RESOLVE_TAG (&tag_convert, open->convert); |
9ad55c33 | 2049 | RESOLVE_TAG (&tag_newunit, open->newunit); |
0ef33d44 FR |
2050 | RESOLVE_TAG (&tag_e_share, open->share); |
2051 | RESOLVE_TAG (&tag_cc, open->cc); | |
6de9cd9a | 2052 | |
524af0d6 JB |
2053 | if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) |
2054 | return false; | |
6de9cd9a | 2055 | |
44facdb7 | 2056 | return check_open_constraints (open, where); |
6de9cd9a DN |
2057 | } |
2058 | ||
2059 | ||
16dbbd99 FXC |
2060 | /* Check if a given value for a SPECIFIER is either in the list of values |
2061 | allowed in F95 or F2003, issuing an error message and returning a zero | |
2062 | value if it is not allowed. */ | |
b251af97 | 2063 | |
a4792d44 TK |
2064 | |
2065 | static int | |
2066 | compare_to_allowed_values (const char *specifier, const char *allowed[], | |
44facdb7 | 2067 | const char *allowed_f2003[], |
a4792d44 | 2068 | const char *allowed_gnu[], gfc_char_t *value, |
44facdb7 FR |
2069 | const char *statement, bool warn, locus *where, |
2070 | int *num) | |
16dbbd99 FXC |
2071 | { |
2072 | int i; | |
2073 | unsigned int len; | |
2074 | ||
00660189 | 2075 | len = gfc_wide_strlen (value); |
16dbbd99 FXC |
2076 | if (len > 0) |
2077 | { | |
2078 | for (len--; len > 0; len--) | |
2079 | if (value[len] != ' ') | |
2080 | break; | |
2081 | len++; | |
2082 | } | |
2083 | ||
2084 | for (i = 0; allowed[i]; i++) | |
b251af97 | 2085 | if (len == strlen (allowed[i]) |
00660189 | 2086 | && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) |
a4792d44 TK |
2087 | { |
2088 | if (num) | |
2089 | *num = i; | |
16dbbd99 | 2090 | return 1; |
a4792d44 | 2091 | } |
16dbbd99 | 2092 | |
44facdb7 FR |
2093 | if (!where) |
2094 | where = &gfc_current_locus; | |
2095 | ||
16dbbd99 | 2096 | for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) |
b251af97 | 2097 | if (len == strlen (allowed_f2003[i]) |
00660189 FXC |
2098 | && gfc_wide_strncasecmp (value, allowed_f2003[i], |
2099 | strlen (allowed_f2003[i])) == 0) | |
16dbbd99 FXC |
2100 | { |
2101 | notification n = gfc_notification_std (GFC_STD_F2003); | |
2102 | ||
2103 | if (n == WARNING || (warn && n == ERROR)) | |
2104 | { | |
44facdb7 FR |
2105 | gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L " |
2106 | "has value %qs", specifier, statement, where, | |
16dbbd99 FXC |
2107 | allowed_f2003[i]); |
2108 | return 1; | |
2109 | } | |
2110 | else | |
2111 | if (n == ERROR) | |
2112 | { | |
9717f7a1 | 2113 | gfc_notify_std (GFC_STD_F2003, "%s specifier in " |
44facdb7 FR |
2114 | "%s statement at %L has value %qs", specifier, |
2115 | statement, where, allowed_f2003[i]); | |
16dbbd99 FXC |
2116 | return 0; |
2117 | } | |
2118 | ||
2119 | /* n == SILENT */ | |
2120 | return 1; | |
2121 | } | |
2122 | ||
2123 | for (i = 0; allowed_gnu && allowed_gnu[i]; i++) | |
b251af97 | 2124 | if (len == strlen (allowed_gnu[i]) |
00660189 FXC |
2125 | && gfc_wide_strncasecmp (value, allowed_gnu[i], |
2126 | strlen (allowed_gnu[i])) == 0) | |
16dbbd99 FXC |
2127 | { |
2128 | notification n = gfc_notification_std (GFC_STD_GNU); | |
2129 | ||
2130 | if (n == WARNING || (warn && n == ERROR)) | |
2131 | { | |
44facdb7 FR |
2132 | gfc_warning (0, "Extension: %s specifier in %s statement at %L " |
2133 | "has value %qs", specifier, statement, where, | |
16dbbd99 FXC |
2134 | allowed_gnu[i]); |
2135 | return 1; | |
2136 | } | |
2137 | else | |
2138 | if (n == ERROR) | |
2139 | { | |
9717f7a1 | 2140 | gfc_notify_std (GFC_STD_GNU, "%s specifier in " |
44facdb7 FR |
2141 | "%s statement at %L has value %qs", specifier, |
2142 | statement, where, allowed_gnu[i]); | |
16dbbd99 FXC |
2143 | return 0; |
2144 | } | |
2145 | ||
2146 | /* n == SILENT */ | |
2147 | return 1; | |
2148 | } | |
2149 | ||
2150 | if (warn) | |
2151 | { | |
00660189 | 2152 | char *s = gfc_widechar_to_char (value, -1); |
db30e21c | 2153 | gfc_warning (0, |
44facdb7 FR |
2154 | "%s specifier in %s statement at %L has invalid value %qs", |
2155 | specifier, statement, where, s); | |
cede9502 | 2156 | free (s); |
16dbbd99 FXC |
2157 | return 1; |
2158 | } | |
2159 | else | |
2160 | { | |
00660189 | 2161 | char *s = gfc_widechar_to_char (value, -1); |
44facdb7 FR |
2162 | gfc_error ("%s specifier in %s statement at %L has invalid value %qs", |
2163 | specifier, statement, where, s); | |
cede9502 | 2164 | free (s); |
16dbbd99 FXC |
2165 | return 0; |
2166 | } | |
2167 | } | |
2168 | ||
b251af97 | 2169 | |
44facdb7 FR |
2170 | /* Check constraints on the OPEN statement. |
2171 | Similar to check_io_constraints for data transfer statements. | |
2172 | At this point all tags have already been resolved via resolve_tag, which, | |
2173 | among other things, verifies that BT_CHARACTER tags are of default kind. */ | |
6de9cd9a | 2174 | |
44facdb7 FR |
2175 | static bool |
2176 | check_open_constraints (gfc_open *open, locus *where) | |
6de9cd9a | 2177 | { |
44facdb7 FR |
2178 | #define warn_or_error(...) \ |
2179 | { \ | |
2180 | if (warn) \ | |
2181 | gfc_warning (0, __VA_ARGS__); \ | |
2182 | else \ | |
2183 | { \ | |
2184 | gfc_error (__VA_ARGS__); \ | |
2185 | return false; \ | |
2186 | } \ | |
2187 | } | |
f1f39033 | 2188 | |
44facdb7 | 2189 | bool warn = (open->err || open->iostat) ? true : false; |
9ad55c33 | 2190 | |
16dbbd99 FXC |
2191 | /* Checks on the ACCESS specifier. */ |
2192 | if (open->access && open->access->expr_type == EXPR_CONSTANT) | |
2193 | { | |
b251af97 SK |
2194 | static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL }; |
2195 | static const char *access_f2003[] = { "STREAM", NULL }; | |
2196 | static const char *access_gnu[] = { "APPEND", NULL }; | |
16dbbd99 FXC |
2197 | |
2198 | if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, | |
2199 | access_gnu, | |
2200 | open->access->value.character.string, | |
44facdb7 FR |
2201 | "OPEN", warn, &open->access->where)) |
2202 | return false; | |
16dbbd99 FXC |
2203 | } |
2204 | ||
2205 | /* Checks on the ACTION specifier. */ | |
2206 | if (open->action && open->action->expr_type == EXPR_CONSTANT) | |
2207 | { | |
0ef33d44 | 2208 | gfc_char_t *str = open->action->value.character.string; |
b251af97 | 2209 | static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; |
16dbbd99 FXC |
2210 | |
2211 | if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, | |
44facdb7 FR |
2212 | str, "OPEN", warn, &open->action->where)) |
2213 | return false; | |
0ef33d44 FR |
2214 | |
2215 | /* With READONLY, only allow ACTION='READ'. */ | |
2216 | if (open->readonly && (gfc_wide_strlen (str) != 4 | |
2217 | || gfc_wide_strncasecmp (str, "READ", 4) != 0)) | |
2218 | { | |
44facdb7 FR |
2219 | gfc_error ("ACTION type conflicts with READONLY specifier at %L", |
2220 | &open->action->where); | |
2221 | return false; | |
0ef33d44 FR |
2222 | } |
2223 | } | |
44facdb7 | 2224 | |
0ef33d44 FR |
2225 | /* If we see READONLY and no ACTION, set ACTION='READ'. */ |
2226 | else if (open->readonly && open->action == NULL) | |
2227 | { | |
2228 | open->action = gfc_get_character_expr (gfc_default_character_kind, | |
2229 | &gfc_current_locus, "read", 4); | |
16dbbd99 FXC |
2230 | } |
2231 | ||
2232 | /* Checks on the ASYNCHRONOUS specifier. */ | |
6f0f0b2e | 2233 | if (open->asynchronous) |
16dbbd99 | 2234 | { |
44facdb7 FR |
2235 | if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L " |
2236 | "not allowed in Fortran 95", | |
2237 | &open->asynchronous->where)) | |
2238 | return false; | |
87550b74 | 2239 | |
6f0f0b2e JD |
2240 | if (open->asynchronous->expr_type == EXPR_CONSTANT) |
2241 | { | |
2242 | static const char * asynchronous[] = { "YES", "NO", NULL }; | |
2243 | ||
2244 | if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, | |
2245 | NULL, NULL, open->asynchronous->value.character.string, | |
44facdb7 FR |
2246 | "OPEN", warn, &open->asynchronous->where)) |
2247 | return false; | |
6f0f0b2e JD |
2248 | } |
2249 | } | |
2250 | ||
16dbbd99 | 2251 | /* Checks on the BLANK specifier. */ |
6f0f0b2e | 2252 | if (open->blank) |
16dbbd99 | 2253 | { |
44facdb7 FR |
2254 | if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " |
2255 | "not allowed in Fortran 95", &open->blank->where)) | |
2256 | return false; | |
2e431643 | 2257 | |
6f0f0b2e JD |
2258 | if (open->blank->expr_type == EXPR_CONSTANT) |
2259 | { | |
2260 | static const char *blank[] = { "ZERO", "NULL", NULL }; | |
2261 | ||
2262 | if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, | |
2263 | open->blank->value.character.string, | |
44facdb7 FR |
2264 | "OPEN", warn, &open->blank->where)) |
2265 | return false; | |
6f0f0b2e | 2266 | } |
16dbbd99 FXC |
2267 | } |
2268 | ||
0ef33d44 | 2269 | /* Checks on the CARRIAGECONTROL specifier. */ |
44facdb7 | 2270 | if (open->cc && open->cc->expr_type == EXPR_CONSTANT) |
0ef33d44 | 2271 | { |
44facdb7 FR |
2272 | static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; |
2273 | if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, | |
2274 | open->cc->value.character.string, | |
2275 | "OPEN", warn, &open->cc->where)) | |
2276 | return false; | |
0ef33d44 FR |
2277 | } |
2278 | ||
16dbbd99 | 2279 | /* Checks on the DECIMAL specifier. */ |
6f0f0b2e | 2280 | if (open->decimal) |
16dbbd99 | 2281 | { |
44facdb7 FR |
2282 | if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " |
2283 | "not allowed in Fortran 95", &open->decimal->where)) | |
2284 | return false; | |
2e431643 | 2285 | |
6f0f0b2e JD |
2286 | if (open->decimal->expr_type == EXPR_CONSTANT) |
2287 | { | |
2288 | static const char * decimal[] = { "COMMA", "POINT", NULL }; | |
2289 | ||
2290 | if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, | |
2291 | open->decimal->value.character.string, | |
44facdb7 FR |
2292 | "OPEN", warn, &open->decimal->where)) |
2293 | return false; | |
6f0f0b2e JD |
2294 | } |
2295 | } | |
16dbbd99 FXC |
2296 | |
2297 | /* Checks on the DELIM specifier. */ | |
6f0f0b2e | 2298 | if (open->delim) |
16dbbd99 | 2299 | { |
6f0f0b2e JD |
2300 | if (open->delim->expr_type == EXPR_CONSTANT) |
2301 | { | |
2302 | static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; | |
2303 | ||
2304 | if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, | |
2305 | open->delim->value.character.string, | |
44facdb7 FR |
2306 | "OPEN", warn, &open->delim->where)) |
2307 | return false; | |
6f0f0b2e | 2308 | } |
16dbbd99 FXC |
2309 | } |
2310 | ||
2311 | /* Checks on the ENCODING specifier. */ | |
6f0f0b2e | 2312 | if (open->encoding) |
16dbbd99 | 2313 | { |
44facdb7 FR |
2314 | if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L " |
2315 | "not allowed in Fortran 95", &open->encoding->where)) | |
2316 | return false; | |
2e431643 | 2317 | |
6f0f0b2e JD |
2318 | if (open->encoding->expr_type == EXPR_CONSTANT) |
2319 | { | |
dad80a1b | 2320 | static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; |
16dbbd99 | 2321 | |
6f0f0b2e JD |
2322 | if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, |
2323 | open->encoding->value.character.string, | |
44facdb7 FR |
2324 | "OPEN", warn, &open->encoding->where)) |
2325 | return false; | |
6f0f0b2e JD |
2326 | } |
2327 | } | |
16dbbd99 FXC |
2328 | |
2329 | /* Checks on the FORM specifier. */ | |
2330 | if (open->form && open->form->expr_type == EXPR_CONSTANT) | |
2331 | { | |
b251af97 | 2332 | static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; |
16dbbd99 FXC |
2333 | |
2334 | if (!compare_to_allowed_values ("FORM", form, NULL, NULL, | |
2335 | open->form->value.character.string, | |
44facdb7 FR |
2336 | "OPEN", warn, &open->form->where)) |
2337 | return false; | |
16dbbd99 FXC |
2338 | } |
2339 | ||
2340 | /* Checks on the PAD specifier. */ | |
2341 | if (open->pad && open->pad->expr_type == EXPR_CONSTANT) | |
2342 | { | |
b251af97 | 2343 | static const char *pad[] = { "YES", "NO", NULL }; |
16dbbd99 FXC |
2344 | |
2345 | if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, | |
2346 | open->pad->value.character.string, | |
44facdb7 FR |
2347 | "OPEN", warn, &open->pad->where)) |
2348 | return false; | |
16dbbd99 FXC |
2349 | } |
2350 | ||
2351 | /* Checks on the POSITION specifier. */ | |
2352 | if (open->position && open->position->expr_type == EXPR_CONSTANT) | |
2353 | { | |
b251af97 | 2354 | static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; |
16dbbd99 FXC |
2355 | |
2356 | if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, | |
2357 | open->position->value.character.string, | |
44facdb7 FR |
2358 | "OPEN", warn, &open->position->where)) |
2359 | return false; | |
16dbbd99 FXC |
2360 | } |
2361 | ||
2362 | /* Checks on the ROUND specifier. */ | |
6f0f0b2e | 2363 | if (open->round) |
16dbbd99 | 2364 | { |
44facdb7 FR |
2365 | if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " |
2366 | "not allowed in Fortran 95", &open->round->where)) | |
2367 | return false; | |
2e431643 | 2368 | |
6f0f0b2e JD |
2369 | if (open->round->expr_type == EXPR_CONSTANT) |
2370 | { | |
2371 | static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", | |
2372 | "COMPATIBLE", "PROCESSOR_DEFINED", | |
2373 | NULL }; | |
2374 | ||
2375 | if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, | |
2376 | open->round->value.character.string, | |
44facdb7 FR |
2377 | "OPEN", warn, &open->round->where)) |
2378 | return false; | |
6f0f0b2e JD |
2379 | } |
2380 | } | |
16dbbd99 | 2381 | |
0ef33d44 | 2382 | /* Checks on the SHARE specifier. */ |
44facdb7 | 2383 | if (open->share && open->share->expr_type == EXPR_CONSTANT) |
0ef33d44 | 2384 | { |
44facdb7 FR |
2385 | static const char *share[] = { "DENYNONE", "DENYRW", NULL }; |
2386 | if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, | |
2387 | open->share->value.character.string, | |
2388 | "OPEN", warn, &open->share->where)) | |
2389 | return false; | |
0ef33d44 FR |
2390 | } |
2391 | ||
16dbbd99 | 2392 | /* Checks on the SIGN specifier. */ |
44facdb7 | 2393 | if (open->sign) |
16dbbd99 | 2394 | { |
44facdb7 FR |
2395 | if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " |
2396 | "not allowed in Fortran 95", &open->sign->where)) | |
2397 | return false; | |
2e431643 | 2398 | |
6f0f0b2e JD |
2399 | if (open->sign->expr_type == EXPR_CONSTANT) |
2400 | { | |
2401 | static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", | |
2402 | NULL }; | |
2403 | ||
2404 | if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, | |
2405 | open->sign->value.character.string, | |
44facdb7 FR |
2406 | "OPEN", warn, &open->sign->where)) |
2407 | return false; | |
6f0f0b2e JD |
2408 | } |
2409 | } | |
16dbbd99 | 2410 | |
16dbbd99 FXC |
2411 | /* Checks on the RECL specifier. */ |
2412 | if (open->recl && open->recl->expr_type == EXPR_CONSTANT | |
2413 | && open->recl->ts.type == BT_INTEGER | |
2414 | && mpz_sgn (open->recl->value.integer) != 1) | |
2415 | { | |
0a7183f6 | 2416 | warn_or_error (G_("RECL in OPEN statement at %L must be positive"), |
44facdb7 | 2417 | &open->recl->where); |
16dbbd99 FXC |
2418 | } |
2419 | ||
2420 | /* Checks on the STATUS specifier. */ | |
2421 | if (open->status && open->status->expr_type == EXPR_CONSTANT) | |
2422 | { | |
b251af97 | 2423 | static const char *status[] = { "OLD", "NEW", "SCRATCH", |
16dbbd99 FXC |
2424 | "REPLACE", "UNKNOWN", NULL }; |
2425 | ||
2426 | if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, | |
2427 | open->status->value.character.string, | |
44facdb7 FR |
2428 | "OPEN", warn, &open->status->where)) |
2429 | return false; | |
16dbbd99 | 2430 | |
d06b3496 JD |
2431 | /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, |
2432 | the FILE= specifier shall appear. */ | |
b251af97 | 2433 | if (open->file == NULL |
00660189 FXC |
2434 | && (gfc_wide_strncasecmp (open->status->value.character.string, |
2435 | "replace", 7) == 0 | |
2436 | || gfc_wide_strncasecmp (open->status->value.character.string, | |
2437 | "new", 3) == 0)) | |
16dbbd99 | 2438 | { |
00660189 FXC |
2439 | char *s = gfc_widechar_to_char (open->status->value.character.string, |
2440 | -1); | |
0a7183f6 ME |
2441 | warn_or_error (G_("The STATUS specified in OPEN statement at %L is " |
2442 | "%qs and no FILE specifier is present"), | |
44facdb7 | 2443 | &open->status->where, s); |
cede9502 | 2444 | free (s); |
16dbbd99 FXC |
2445 | } |
2446 | ||
d06b3496 JD |
2447 | /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, |
2448 | the FILE= specifier shall not appear. */ | |
00660189 FXC |
2449 | if (gfc_wide_strncasecmp (open->status->value.character.string, |
2450 | "scratch", 7) == 0 && open->file) | |
16dbbd99 | 2451 | { |
0a7183f6 | 2452 | warn_or_error (G_("The STATUS specified in OPEN statement at %L " |
b251af97 | 2453 | "cannot have the value SCRATCH if a FILE specifier " |
0a7183f6 | 2454 | "is present"), &open->status->where); |
16dbbd99 FXC |
2455 | } |
2456 | } | |
2457 | ||
72eb8e78 SK |
2458 | /* Checks on NEWUNIT specifier. */ |
2459 | if (open->newunit) | |
2460 | { | |
2461 | if (open->unit) | |
2462 | { | |
44facdb7 FR |
2463 | gfc_error ("UNIT specifier not allowed with NEWUNIT at %L", |
2464 | &open->newunit->where); | |
2465 | return false; | |
72eb8e78 SK |
2466 | } |
2467 | ||
56bf85c1 HA |
2468 | if (!open->file && |
2469 | (!open->status || | |
2470 | (open->status->expr_type == EXPR_CONSTANT | |
72eb8e78 | 2471 | && gfc_wide_strncasecmp (open->status->value.character.string, |
56bf85c1 HA |
2472 | "scratch", 7) != 0))) |
2473 | { | |
72eb8e78 | 2474 | gfc_error ("NEWUNIT specifier must have FILE= " |
44facdb7 FR |
2475 | "or STATUS='scratch' at %L", &open->newunit->where); |
2476 | return false; | |
72eb8e78 SK |
2477 | } |
2478 | } | |
2479 | else if (!open->unit) | |
2480 | { | |
44facdb7 FR |
2481 | gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified", |
2482 | where); | |
2483 | return false; | |
72eb8e78 SK |
2484 | } |
2485 | ||
16dbbd99 FXC |
2486 | /* Things that are not allowed for unformatted I/O. */ |
2487 | if (open->form && open->form->expr_type == EXPR_CONSTANT | |
6f0f0b2e JD |
2488 | && (open->delim || open->decimal || open->encoding || open->round |
2489 | || open->sign || open->pad || open->blank) | |
00660189 FXC |
2490 | && gfc_wide_strncasecmp (open->form->value.character.string, |
2491 | "unformatted", 11) == 0) | |
16dbbd99 | 2492 | { |
44facdb7 FR |
2493 | locus *loc; |
2494 | const char *spec; | |
2495 | if (open->delim) | |
2496 | { | |
2497 | loc = &open->delim->where; | |
2498 | spec = "DELIM "; | |
2499 | } | |
2500 | else if (open->pad) | |
2501 | { | |
2502 | loc = &open->pad->where; | |
2503 | spec = "PAD "; | |
2504 | } | |
2505 | else if (open->blank) | |
2506 | { | |
2507 | loc = &open->blank->where; | |
2508 | spec = "BLANK "; | |
2509 | } | |
2510 | else | |
2511 | { | |
2512 | loc = where; | |
2513 | spec = ""; | |
2514 | } | |
16dbbd99 | 2515 | |
0a7183f6 ME |
2516 | warn_or_error (G_("%s specifier at %L not allowed in OPEN statement for " |
2517 | "unformatted I/O"), spec, loc); | |
16dbbd99 FXC |
2518 | } |
2519 | ||
2520 | if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT | |
00660189 FXC |
2521 | && gfc_wide_strncasecmp (open->access->value.character.string, |
2522 | "stream", 6) == 0) | |
16dbbd99 | 2523 | { |
0a7183f6 ME |
2524 | warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for " |
2525 | "stream I/O"), &open->recl->where); | |
16dbbd99 FXC |
2526 | } |
2527 | ||
b251af97 SK |
2528 | if (open->position |
2529 | && open->access && open->access->expr_type == EXPR_CONSTANT | |
00660189 FXC |
2530 | && !(gfc_wide_strncasecmp (open->access->value.character.string, |
2531 | "sequential", 10) == 0 | |
2532 | || gfc_wide_strncasecmp (open->access->value.character.string, | |
2533 | "stream", 6) == 0 | |
2534 | || gfc_wide_strncasecmp (open->access->value.character.string, | |
2535 | "append", 6) == 0)) | |
16dbbd99 | 2536 | { |
0a7183f6 ME |
2537 | warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed " |
2538 | "for stream or sequential ACCESS"), &open->position->where); | |
16dbbd99 FXC |
2539 | } |
2540 | ||
44facdb7 | 2541 | return true; |
16dbbd99 | 2542 | #undef warn_or_error |
44facdb7 FR |
2543 | } |
2544 | ||
2545 | ||
2546 | /* Match an OPEN statement. */ | |
2547 | ||
2548 | match | |
2549 | gfc_match_open (void) | |
2550 | { | |
2551 | gfc_open *open; | |
2552 | match m; | |
2553 | ||
2554 | m = gfc_match_char ('('); | |
2555 | if (m == MATCH_NO) | |
2556 | return m; | |
2557 | ||
2558 | open = XCNEW (gfc_open); | |
2559 | ||
2560 | m = match_open_element (open); | |
2561 | ||
2562 | if (m == MATCH_ERROR) | |
2563 | goto cleanup; | |
2564 | if (m == MATCH_NO) | |
2565 | { | |
2566 | m = gfc_match_expr (&open->unit); | |
2567 | if (m == MATCH_ERROR) | |
2568 | goto cleanup; | |
2569 | } | |
2570 | ||
2571 | for (;;) | |
2572 | { | |
2573 | if (gfc_match_char (')') == MATCH_YES) | |
2574 | break; | |
2575 | if (gfc_match_char (',') != MATCH_YES) | |
2576 | goto syntax; | |
2577 | ||
2578 | m = match_open_element (open); | |
2579 | if (m == MATCH_ERROR) | |
2580 | goto cleanup; | |
2581 | if (m == MATCH_NO) | |
2582 | goto syntax; | |
2583 | } | |
2584 | ||
2585 | if (gfc_match_eos () == MATCH_NO) | |
2586 | goto syntax; | |
2587 | ||
2588 | if (gfc_pure (NULL)) | |
2589 | { | |
2590 | gfc_error ("OPEN statement not allowed in PURE procedure at %C"); | |
2591 | goto cleanup; | |
2592 | } | |
2593 | ||
2594 | gfc_unset_implicit_pure (NULL); | |
16dbbd99 | 2595 | |
6de9cd9a DN |
2596 | new_st.op = EXEC_OPEN; |
2597 | new_st.ext.open = open; | |
2598 | return MATCH_YES; | |
2599 | ||
2600 | syntax: | |
2601 | gfc_syntax_error (ST_OPEN); | |
2602 | ||
2603 | cleanup: | |
2604 | gfc_free_open (open); | |
2605 | return MATCH_ERROR; | |
2606 | } | |
2607 | ||
2608 | ||
2609 | /* Free a gfc_close structure an all its expressions. */ | |
2610 | ||
2611 | void | |
b251af97 | 2612 | gfc_free_close (gfc_close *close) |
6de9cd9a | 2613 | { |
6de9cd9a DN |
2614 | if (close == NULL) |
2615 | return; | |
2616 | ||
2617 | gfc_free_expr (close->unit); | |
7aba8abe | 2618 | gfc_free_expr (close->iomsg); |
6de9cd9a DN |
2619 | gfc_free_expr (close->iostat); |
2620 | gfc_free_expr (close->status); | |
cede9502 | 2621 | free (close); |
6de9cd9a DN |
2622 | } |
2623 | ||
2624 | ||
e7dc5b4f | 2625 | /* Match elements of a CLOSE statement. */ |
6de9cd9a DN |
2626 | |
2627 | static match | |
b251af97 | 2628 | match_close_element (gfc_close *close) |
6de9cd9a DN |
2629 | { |
2630 | match m; | |
2631 | ||
2632 | m = match_etag (&tag_unit, &close->unit); | |
2633 | if (m != MATCH_NO) | |
2634 | return m; | |
2635 | m = match_etag (&tag_status, &close->status); | |
7aba8abe TK |
2636 | if (m != MATCH_NO) |
2637 | return m; | |
fd5cabb2 | 2638 | m = match_etag (&tag_iomsg, &close->iomsg); |
6de9cd9a DN |
2639 | if (m != MATCH_NO) |
2640 | return m; | |
c9583ed2 | 2641 | m = match_out_tag (&tag_iostat, &close->iostat); |
6de9cd9a DN |
2642 | if (m != MATCH_NO) |
2643 | return m; | |
2644 | m = match_ltag (&tag_err, &close->err); | |
2645 | if (m != MATCH_NO) | |
2646 | return m; | |
2647 | ||
2648 | return MATCH_NO; | |
2649 | } | |
2650 | ||
2651 | ||
2652 | /* Match a CLOSE statement. */ | |
2653 | ||
2654 | match | |
2655 | gfc_match_close (void) | |
2656 | { | |
2657 | gfc_close *close; | |
2658 | match m; | |
2659 | ||
2660 | m = gfc_match_char ('('); | |
2661 | if (m == MATCH_NO) | |
2662 | return m; | |
2663 | ||
ece3f663 | 2664 | close = XCNEW (gfc_close); |
6de9cd9a DN |
2665 | |
2666 | m = match_close_element (close); | |
2667 | ||
2668 | if (m == MATCH_ERROR) | |
2669 | goto cleanup; | |
2670 | if (m == MATCH_NO) | |
2671 | { | |
2672 | m = gfc_match_expr (&close->unit); | |
2673 | if (m == MATCH_NO) | |
2674 | goto syntax; | |
2675 | if (m == MATCH_ERROR) | |
2676 | goto cleanup; | |
2677 | } | |
2678 | ||
2679 | for (;;) | |
2680 | { | |
2681 | if (gfc_match_char (')') == MATCH_YES) | |
2682 | break; | |
2683 | if (gfc_match_char (',') != MATCH_YES) | |
2684 | goto syntax; | |
2685 | ||
2686 | m = match_close_element (close); | |
2687 | if (m == MATCH_ERROR) | |
2688 | goto cleanup; | |
2689 | if (m == MATCH_NO) | |
2690 | goto syntax; | |
2691 | } | |
2692 | ||
2693 | if (gfc_match_eos () == MATCH_NO) | |
2694 | goto syntax; | |
2695 | ||
2696 | if (gfc_pure (NULL)) | |
2697 | { | |
2698 | gfc_error ("CLOSE statement not allowed in PURE procedure at %C"); | |
2699 | goto cleanup; | |
2700 | } | |
2701 | ||
ccd7751b | 2702 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 2703 | |
6de9cd9a DN |
2704 | new_st.op = EXEC_CLOSE; |
2705 | new_st.ext.close = close; | |
2706 | return MATCH_YES; | |
2707 | ||
2708 | syntax: | |
2709 | gfc_syntax_error (ST_CLOSE); | |
2710 | ||
2711 | cleanup: | |
2712 | gfc_free_close (close); | |
2713 | return MATCH_ERROR; | |
2714 | } | |
2715 | ||
2716 | ||
44facdb7 FR |
2717 | static bool |
2718 | check_close_constraints (gfc_close *close, locus *where) | |
6de9cd9a | 2719 | { |
44facdb7 | 2720 | bool warn = (close->iostat || close->err) ? true : false; |
6de9cd9a | 2721 | |
b35f6a97 FXC |
2722 | if (close->unit == NULL) |
2723 | { | |
44facdb7 | 2724 | gfc_error ("CLOSE statement at %L requires a UNIT number", where); |
524af0d6 | 2725 | return false; |
b35f6a97 FXC |
2726 | } |
2727 | ||
9ad55c33 JD |
2728 | if (close->unit->expr_type == EXPR_CONSTANT |
2729 | && close->unit->ts.type == BT_INTEGER | |
2730 | && mpz_sgn (close->unit->value.integer) < 0) | |
2731 | { | |
2732 | gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", | |
2733 | &close->unit->where); | |
2734 | } | |
2735 | ||
44facdb7 FR |
2736 | /* Checks on the STATUS specifier. */ |
2737 | if (close->status && close->status->expr_type == EXPR_CONSTANT) | |
2738 | { | |
2739 | static const char *status[] = { "KEEP", "DELETE", NULL }; | |
2740 | ||
2741 | if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, | |
2742 | close->status->value.character.string, | |
2743 | "CLOSE", warn, &close->status->where)) | |
2744 | return false; | |
2745 | } | |
2746 | ||
524af0d6 | 2747 | return true; |
6de9cd9a DN |
2748 | } |
2749 | ||
44facdb7 FR |
2750 | /* Resolve everything in a gfc_close structure. */ |
2751 | ||
2752 | bool | |
2753 | gfc_resolve_close (gfc_close *close, locus *where) | |
2754 | { | |
2755 | RESOLVE_TAG (&tag_unit, close->unit); | |
2756 | RESOLVE_TAG (&tag_iomsg, close->iomsg); | |
2757 | RESOLVE_TAG (&tag_iostat, close->iostat); | |
2758 | RESOLVE_TAG (&tag_status, close->status); | |
2759 | ||
2760 | if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) | |
2761 | return false; | |
2762 | ||
2763 | return check_close_constraints (close, where); | |
2764 | } | |
2765 | ||
6de9cd9a DN |
2766 | |
2767 | /* Free a gfc_filepos structure. */ | |
2768 | ||
2769 | void | |
b251af97 | 2770 | gfc_free_filepos (gfc_filepos *fp) |
6de9cd9a | 2771 | { |
6de9cd9a | 2772 | gfc_free_expr (fp->unit); |
7aba8abe | 2773 | gfc_free_expr (fp->iomsg); |
6de9cd9a | 2774 | gfc_free_expr (fp->iostat); |
cede9502 | 2775 | free (fp); |
6de9cd9a DN |
2776 | } |
2777 | ||
2778 | ||
6403ec5f | 2779 | /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */ |
6de9cd9a DN |
2780 | |
2781 | static match | |
b251af97 | 2782 | match_file_element (gfc_filepos *fp) |
6de9cd9a DN |
2783 | { |
2784 | match m; | |
2785 | ||
2786 | m = match_etag (&tag_unit, &fp->unit); | |
7aba8abe TK |
2787 | if (m != MATCH_NO) |
2788 | return m; | |
fd5cabb2 | 2789 | m = match_etag (&tag_iomsg, &fp->iomsg); |
6de9cd9a DN |
2790 | if (m != MATCH_NO) |
2791 | return m; | |
c9583ed2 | 2792 | m = match_out_tag (&tag_iostat, &fp->iostat); |
6de9cd9a DN |
2793 | if (m != MATCH_NO) |
2794 | return m; | |
2795 | m = match_ltag (&tag_err, &fp->err); | |
2796 | if (m != MATCH_NO) | |
2797 | return m; | |
2798 | ||
2799 | return MATCH_NO; | |
2800 | } | |
2801 | ||
2802 | ||
2803 | /* Match the second half of the file-positioning statements, REWIND, | |
6403ec5f | 2804 | BACKSPACE, ENDFILE, or the FLUSH statement. */ |
6de9cd9a DN |
2805 | |
2806 | static match | |
2807 | match_filepos (gfc_statement st, gfc_exec_op op) | |
2808 | { | |
2809 | gfc_filepos *fp; | |
2810 | match m; | |
2811 | ||
ece3f663 | 2812 | fp = XCNEW (gfc_filepos); |
6de9cd9a DN |
2813 | |
2814 | if (gfc_match_char ('(') == MATCH_NO) | |
2815 | { | |
2816 | m = gfc_match_expr (&fp->unit); | |
2817 | if (m == MATCH_ERROR) | |
2818 | goto cleanup; | |
2819 | if (m == MATCH_NO) | |
2820 | goto syntax; | |
2821 | ||
2822 | goto done; | |
2823 | } | |
2824 | ||
2825 | m = match_file_element (fp); | |
2826 | if (m == MATCH_ERROR) | |
939e9f69 | 2827 | goto cleanup; |
6de9cd9a DN |
2828 | if (m == MATCH_NO) |
2829 | { | |
2830 | m = gfc_match_expr (&fp->unit); | |
20898e80 | 2831 | if (m == MATCH_ERROR || m == MATCH_NO) |
6de9cd9a DN |
2832 | goto syntax; |
2833 | } | |
2834 | ||
2835 | for (;;) | |
2836 | { | |
2837 | if (gfc_match_char (')') == MATCH_YES) | |
2838 | break; | |
2839 | if (gfc_match_char (',') != MATCH_YES) | |
2840 | goto syntax; | |
2841 | ||
2842 | m = match_file_element (fp); | |
2843 | if (m == MATCH_ERROR) | |
2844 | goto cleanup; | |
2845 | if (m == MATCH_NO) | |
2846 | goto syntax; | |
2847 | } | |
2848 | ||
2849 | done: | |
2850 | if (gfc_match_eos () != MATCH_YES) | |
2851 | goto syntax; | |
2852 | ||
2853 | if (gfc_pure (NULL)) | |
2854 | { | |
2855 | gfc_error ("%s statement not allowed in PURE procedure at %C", | |
2856 | gfc_ascii_statement (st)); | |
2857 | ||
2858 | goto cleanup; | |
2859 | } | |
2860 | ||
ccd7751b | 2861 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 2862 | |
6de9cd9a DN |
2863 | new_st.op = op; |
2864 | new_st.ext.filepos = fp; | |
2865 | return MATCH_YES; | |
2866 | ||
2867 | syntax: | |
2868 | gfc_syntax_error (st); | |
2869 | ||
2870 | cleanup: | |
2871 | gfc_free_filepos (fp); | |
2872 | return MATCH_ERROR; | |
2873 | } | |
2874 | ||
2875 | ||
524af0d6 | 2876 | bool |
3d07fb21 | 2877 | gfc_resolve_filepos (gfc_filepos *fp, locus *where) |
6de9cd9a | 2878 | { |
6de9cd9a | 2879 | RESOLVE_TAG (&tag_unit, fp->unit); |
7aba8abe TK |
2880 | RESOLVE_TAG (&tag_iostat, fp->iostat); |
2881 | RESOLVE_TAG (&tag_iomsg, fp->iomsg); | |
6de9cd9a | 2882 | |
3d07fb21 | 2883 | if (!fp->unit && (fp->iostat || fp->iomsg || fp->err)) |
220ab6b4 | 2884 | { |
3d07fb21 | 2885 | gfc_error ("UNIT number missing in statement at %L", where); |
220ab6b4 SK |
2886 | return false; |
2887 | } | |
2888 | ||
3d07fb21 SK |
2889 | if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) |
2890 | return false; | |
2891 | ||
9ad55c33 JD |
2892 | if (fp->unit->expr_type == EXPR_CONSTANT |
2893 | && fp->unit->ts.type == BT_INTEGER | |
2894 | && mpz_sgn (fp->unit->value.integer) < 0) | |
2895 | { | |
2896 | gfc_error ("UNIT number in statement at %L must be non-negative", | |
2897 | &fp->unit->where); | |
220ab6b4 | 2898 | return false; |
9ad55c33 JD |
2899 | } |
2900 | ||
524af0d6 | 2901 | return true; |
6de9cd9a DN |
2902 | } |
2903 | ||
2904 | ||
6403ec5f JB |
2905 | /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND, |
2906 | and the FLUSH statement. */ | |
6de9cd9a DN |
2907 | |
2908 | match | |
2909 | gfc_match_endfile (void) | |
2910 | { | |
6de9cd9a DN |
2911 | return match_filepos (ST_END_FILE, EXEC_ENDFILE); |
2912 | } | |
2913 | ||
2914 | match | |
2915 | gfc_match_backspace (void) | |
2916 | { | |
6de9cd9a DN |
2917 | return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE); |
2918 | } | |
2919 | ||
2920 | match | |
2921 | gfc_match_rewind (void) | |
2922 | { | |
6de9cd9a DN |
2923 | return match_filepos (ST_REWIND, EXEC_REWIND); |
2924 | } | |
2925 | ||
6403ec5f JB |
2926 | match |
2927 | gfc_match_flush (void) | |
2928 | { | |
524af0d6 | 2929 | if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C")) |
6403ec5f JB |
2930 | return MATCH_ERROR; |
2931 | ||
2932 | return match_filepos (ST_FLUSH, EXEC_FLUSH); | |
2933 | } | |
6de9cd9a | 2934 | |
e7dc5b4f | 2935 | /******************** Data Transfer Statements *********************/ |
6de9cd9a | 2936 | |
6de9cd9a DN |
2937 | /* Return a default unit number. */ |
2938 | ||
2939 | static gfc_expr * | |
2940 | default_unit (io_kind k) | |
2941 | { | |
2942 | int unit; | |
2943 | ||
2944 | if (k == M_READ) | |
2945 | unit = 5; | |
2946 | else | |
2947 | unit = 6; | |
2948 | ||
b7e75771 | 2949 | return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit); |
6de9cd9a DN |
2950 | } |
2951 | ||
2952 | ||
2953 | /* Match a unit specification for a data transfer statement. */ | |
2954 | ||
2955 | static match | |
b251af97 | 2956 | match_dt_unit (io_kind k, gfc_dt *dt) |
6de9cd9a DN |
2957 | { |
2958 | gfc_expr *e; | |
e3228a50 | 2959 | char c; |
6de9cd9a DN |
2960 | |
2961 | if (gfc_match_char ('*') == MATCH_YES) | |
2962 | { | |
2963 | if (dt->io_unit != NULL) | |
2964 | goto conflict; | |
2965 | ||
2966 | dt->io_unit = default_unit (k); | |
e3228a50 JD |
2967 | |
2968 | c = gfc_peek_ascii_char (); | |
2969 | if (c == ')') | |
2970 | gfc_error_now ("Missing format with default unit at %C"); | |
2971 | ||
6de9cd9a DN |
2972 | return MATCH_YES; |
2973 | } | |
2974 | ||
2975 | if (gfc_match_expr (&e) == MATCH_YES) | |
2976 | { | |
2977 | if (dt->io_unit != NULL) | |
2978 | { | |
2979 | gfc_free_expr (e); | |
2980 | goto conflict; | |
2981 | } | |
2982 | ||
2983 | dt->io_unit = e; | |
2984 | return MATCH_YES; | |
2985 | } | |
2986 | ||
2987 | return MATCH_NO; | |
2988 | ||
2989 | conflict: | |
2990 | gfc_error ("Duplicate UNIT specification at %C"); | |
2991 | return MATCH_ERROR; | |
2992 | } | |
2993 | ||
2994 | ||
2995 | /* Match a format specification. */ | |
2996 | ||
2997 | static match | |
b251af97 | 2998 | match_dt_format (gfc_dt *dt) |
6de9cd9a DN |
2999 | { |
3000 | locus where; | |
3001 | gfc_expr *e; | |
3002 | gfc_st_label *label; | |
a48ebf39 | 3003 | match m; |
6de9cd9a | 3004 | |
63645982 | 3005 | where = gfc_current_locus; |
6de9cd9a DN |
3006 | |
3007 | if (gfc_match_char ('*') == MATCH_YES) | |
3008 | { | |
3009 | if (dt->format_expr != NULL || dt->format_label != NULL) | |
3010 | goto conflict; | |
3011 | ||
3012 | dt->format_label = &format_asterisk; | |
3013 | return MATCH_YES; | |
3014 | } | |
3015 | ||
a48ebf39 | 3016 | if ((m = gfc_match_st_label (&label)) == MATCH_YES) |
6de9cd9a | 3017 | { |
fc3c9491 SK |
3018 | char c; |
3019 | ||
3020 | /* Need to check if the format label is actually either an operand | |
3021 | to a user-defined operator or is a kind type parameter. That is, | |
3022 | print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER. | |
3023 | print 1_'(I0)', i ! 1_'(I0)' is a default character string. */ | |
3024 | ||
3025 | gfc_gobble_whitespace (); | |
3026 | c = gfc_peek_ascii_char (); | |
3027 | if (c == '.' || c == '_') | |
3028 | gfc_current_locus = where; | |
3029 | else | |
6de9cd9a | 3030 | { |
fc3c9491 SK |
3031 | if (dt->format_expr != NULL || dt->format_label != NULL) |
3032 | { | |
3033 | gfc_free_st_label (label); | |
3034 | goto conflict; | |
3035 | } | |
6de9cd9a | 3036 | |
524af0d6 | 3037 | if (!gfc_reference_st_label (label, ST_LABEL_FORMAT)) |
fc3c9491 | 3038 | return MATCH_ERROR; |
6de9cd9a | 3039 | |
fc3c9491 SK |
3040 | dt->format_label = label; |
3041 | return MATCH_YES; | |
3042 | } | |
6de9cd9a | 3043 | } |
a48ebf39 FXC |
3044 | else if (m == MATCH_ERROR) |
3045 | /* The label was zero or too large. Emit the correct diagnosis. */ | |
3046 | return MATCH_ERROR; | |
6de9cd9a DN |
3047 | |
3048 | if (gfc_match_expr (&e) == MATCH_YES) | |
3049 | { | |
3050 | if (dt->format_expr != NULL || dt->format_label != NULL) | |
3051 | { | |
3052 | gfc_free_expr (e); | |
3053 | goto conflict; | |
3054 | } | |
6de9cd9a DN |
3055 | dt->format_expr = e; |
3056 | return MATCH_YES; | |
3057 | } | |
3058 | ||
63645982 | 3059 | gfc_current_locus = where; /* The only case where we have to restore */ |
6de9cd9a DN |
3060 | |
3061 | return MATCH_NO; | |
3062 | ||
3063 | conflict: | |
3064 | gfc_error ("Duplicate format specification at %C"); | |
3065 | return MATCH_ERROR; | |
3066 | } | |
3067 | ||
628c06d6 JD |
3068 | /* Check for formatted read and write DTIO procedures. */ |
3069 | ||
3070 | static bool | |
3071 | dtio_procs_present (gfc_symbol *sym, io_kind k) | |
3072 | { | |
3073 | gfc_symbol *derived; | |
3074 | ||
3075 | if (sym && sym->ts.u.derived) | |
3076 | { | |
3077 | if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) | |
3078 | derived = CLASS_DATA (sym)->ts.u.derived; | |
3079 | else if (sym->ts.type == BT_DERIVED) | |
3080 | derived = sym->ts.u.derived; | |
3081 | else | |
3082 | return false; | |
3083 | if ((k == M_WRITE || k == M_PRINT) && | |
3084 | (gfc_find_specific_dtio_proc (derived, true, true) != NULL)) | |
3085 | return true; | |
3086 | if ((k == M_READ) && | |
3087 | (gfc_find_specific_dtio_proc (derived, false, true) != NULL)) | |
3088 | return true; | |
3089 | } | |
3090 | return false; | |
3091 | } | |
6de9cd9a DN |
3092 | |
3093 | /* Traverse a namelist that is part of a READ statement to make sure | |
3094 | that none of the variables in the namelist are INTENT(IN). Returns | |
3095 | nonzero if we find such a variable. */ | |
3096 | ||
3097 | static int | |
b251af97 | 3098 | check_namelist (gfc_symbol *sym) |
6de9cd9a DN |
3099 | { |
3100 | gfc_namelist *p; | |
3101 | ||
3102 | for (p = sym->namelist; p; p = p->next) | |
3103 | if (p->sym->attr.intent == INTENT_IN) | |
3104 | { | |
a4d9b221 | 3105 | gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C", |
6de9cd9a DN |
3106 | p->sym->name, sym->name); |
3107 | return 1; | |
3108 | } | |
3109 | ||
3110 | return 0; | |
3111 | } | |
3112 | ||
3113 | ||
3114 | /* Match a single data transfer element. */ | |
3115 | ||
3116 | static match | |
b251af97 | 3117 | match_dt_element (io_kind k, gfc_dt *dt) |
6de9cd9a DN |
3118 | { |
3119 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
3120 | gfc_symbol *sym; | |
3121 | match m; | |
3122 | ||
3123 | if (gfc_match (" unit =") == MATCH_YES) | |
3124 | { | |
3125 | m = match_dt_unit (k, dt); | |
3126 | if (m != MATCH_NO) | |
3127 | return m; | |
3128 | } | |
3129 | ||
3130 | if (gfc_match (" fmt =") == MATCH_YES) | |
3131 | { | |
3132 | m = match_dt_format (dt); | |
3133 | if (m != MATCH_NO) | |
3134 | return m; | |
3135 | } | |
3136 | ||
3137 | if (gfc_match (" nml = %n", name) == MATCH_YES) | |
3138 | { | |
3139 | if (dt->namelist != NULL) | |
3140 | { | |
3141 | gfc_error ("Duplicate NML specification at %C"); | |
3142 | return MATCH_ERROR; | |
3143 | } | |
3144 | ||
3145 | if (gfc_find_symbol (name, NULL, 1, &sym)) | |
3146 | return MATCH_ERROR; | |
3147 | ||
3148 | if (sym == NULL || sym->attr.flavor != FL_NAMELIST) | |
3149 | { | |
a4d9b221 | 3150 | gfc_error ("Symbol %qs at %C must be a NAMELIST group name", |
6de9cd9a DN |
3151 | sym != NULL ? sym->name : name); |
3152 | return MATCH_ERROR; | |
3153 | } | |
3154 | ||
3155 | dt->namelist = sym; | |
3156 | if (k == M_READ && check_namelist (sym)) | |
3157 | return MATCH_ERROR; | |
3158 | ||
3159 | return MATCH_YES; | |
3160 | } | |
3161 | ||
d06b3496 | 3162 | m = match_etag (&tag_e_async, &dt->asynchronous); |
6f0f0b2e JD |
3163 | if (m != MATCH_NO) |
3164 | return m; | |
3165 | m = match_etag (&tag_e_blank, &dt->blank); | |
3166 | if (m != MATCH_NO) | |
3167 | return m; | |
3168 | m = match_etag (&tag_e_delim, &dt->delim); | |
3169 | if (m != MATCH_NO) | |
3170 | return m; | |
3171 | m = match_etag (&tag_e_pad, &dt->pad); | |
3172 | if (m != MATCH_NO) | |
3173 | return m; | |
3174 | m = match_etag (&tag_e_sign, &dt->sign); | |
3175 | if (m != MATCH_NO) | |
3176 | return m; | |
3177 | m = match_etag (&tag_e_round, &dt->round); | |
3178 | if (m != MATCH_NO) | |
3179 | return m; | |
3180 | m = match_out_tag (&tag_id, &dt->id); | |
3181 | if (m != MATCH_NO) | |
3182 | return m; | |
3183 | m = match_etag (&tag_e_decimal, &dt->decimal); | |
3184 | if (m != MATCH_NO) | |
3185 | return m; | |
6de9cd9a | 3186 | m = match_etag (&tag_rec, &dt->rec); |
014ec6ee JD |
3187 | if (m != MATCH_NO) |
3188 | return m; | |
4c934d41 | 3189 | m = match_etag (&tag_spos, &dt->pos); |
7aba8abe TK |
3190 | if (m != MATCH_NO) |
3191 | return m; | |
fd5cabb2 | 3192 | m = match_etag (&tag_iomsg, &dt->iomsg); |
6de9cd9a DN |
3193 | if (m != MATCH_NO) |
3194 | return m; | |
2e431643 | 3195 | |
c9583ed2 | 3196 | m = match_out_tag (&tag_iostat, &dt->iostat); |
6de9cd9a DN |
3197 | if (m != MATCH_NO) |
3198 | return m; | |
3199 | m = match_ltag (&tag_err, &dt->err); | |
e0e85e06 PT |
3200 | if (m == MATCH_YES) |
3201 | dt->err_where = gfc_current_locus; | |
6de9cd9a DN |
3202 | if (m != MATCH_NO) |
3203 | return m; | |
3204 | m = match_etag (&tag_advance, &dt->advance); | |
3205 | if (m != MATCH_NO) | |
3206 | return m; | |
c9583ed2 | 3207 | m = match_out_tag (&tag_size, &dt->size); |
6de9cd9a DN |
3208 | if (m != MATCH_NO) |
3209 | return m; | |
3210 | ||
3211 | m = match_ltag (&tag_end, &dt->end); | |
3212 | if (m == MATCH_YES) | |
365ff3b9 FXC |
3213 | { |
3214 | if (k == M_WRITE) | |
3215 | { | |
b251af97 SK |
3216 | gfc_error ("END tag at %C not allowed in output statement"); |
3217 | return MATCH_ERROR; | |
365ff3b9 FXC |
3218 | } |
3219 | dt->end_where = gfc_current_locus; | |
3220 | } | |
6de9cd9a DN |
3221 | if (m != MATCH_NO) |
3222 | return m; | |
3223 | ||
3224 | m = match_ltag (&tag_eor, &dt->eor); | |
3225 | if (m == MATCH_YES) | |
63645982 | 3226 | dt->eor_where = gfc_current_locus; |
6de9cd9a DN |
3227 | if (m != MATCH_NO) |
3228 | return m; | |
3229 | ||
3230 | return MATCH_NO; | |
3231 | } | |
3232 | ||
3233 | ||
3234 | /* Free a data transfer structure and everything below it. */ | |
3235 | ||
3236 | void | |
b251af97 | 3237 | gfc_free_dt (gfc_dt *dt) |
6de9cd9a | 3238 | { |
6de9cd9a DN |
3239 | if (dt == NULL) |
3240 | return; | |
3241 | ||
3242 | gfc_free_expr (dt->io_unit); | |
3243 | gfc_free_expr (dt->format_expr); | |
3244 | gfc_free_expr (dt->rec); | |
3245 | gfc_free_expr (dt->advance); | |
7aba8abe | 3246 | gfc_free_expr (dt->iomsg); |
6de9cd9a DN |
3247 | gfc_free_expr (dt->iostat); |
3248 | gfc_free_expr (dt->size); | |
6f0f0b2e JD |
3249 | gfc_free_expr (dt->pad); |
3250 | gfc_free_expr (dt->delim); | |
3251 | gfc_free_expr (dt->sign); | |
3252 | gfc_free_expr (dt->round); | |
3253 | gfc_free_expr (dt->blank); | |
3254 | gfc_free_expr (dt->decimal); | |
4c934d41 | 3255 | gfc_free_expr (dt->pos); |
8e8dc060 DK |
3256 | gfc_free_expr (dt->dt_io_kind); |
3257 | /* dt->extra_comma is a link to dt_io_kind if it is set. */ | |
cede9502 | 3258 | free (dt); |
6de9cd9a DN |
3259 | } |
3260 | ||
3261 | ||
44facdb7 FR |
3262 | static const char * |
3263 | io_kind_name (io_kind k); | |
3264 | ||
3265 | static bool | |
3266 | check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, | |
3267 | locus *spec_end); | |
3268 | ||
6de9cd9a DN |
3269 | /* Resolve everything in a gfc_dt structure. */ |
3270 | ||
524af0d6 | 3271 | bool |
44facdb7 | 3272 | gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc) |
6de9cd9a DN |
3273 | { |
3274 | gfc_expr *e; | |
8e8dc060 DK |
3275 | io_kind k; |
3276 | ||
3277 | /* This is set in any case. */ | |
3278 | gcc_assert (dt->dt_io_kind); | |
3279 | k = dt->dt_io_kind->value.iokind; | |
6de9cd9a | 3280 | |
44facdb7 | 3281 | RESOLVE_TAG (&tag_format, dt->format_expr); |
6de9cd9a | 3282 | RESOLVE_TAG (&tag_rec, dt->rec); |
4c934d41 | 3283 | RESOLVE_TAG (&tag_spos, dt->pos); |
6de9cd9a | 3284 | RESOLVE_TAG (&tag_advance, dt->advance); |
3446fc50 | 3285 | RESOLVE_TAG (&tag_id, dt->id); |
7aba8abe | 3286 | RESOLVE_TAG (&tag_iomsg, dt->iomsg); |
6de9cd9a DN |
3287 | RESOLVE_TAG (&tag_iostat, dt->iostat); |
3288 | RESOLVE_TAG (&tag_size, dt->size); | |
6f0f0b2e JD |
3289 | RESOLVE_TAG (&tag_e_pad, dt->pad); |
3290 | RESOLVE_TAG (&tag_e_delim, dt->delim); | |
3291 | RESOLVE_TAG (&tag_e_sign, dt->sign); | |
3292 | RESOLVE_TAG (&tag_e_round, dt->round); | |
3293 | RESOLVE_TAG (&tag_e_blank, dt->blank); | |
3294 | RESOLVE_TAG (&tag_e_decimal, dt->decimal); | |
3446fc50 | 3295 | RESOLVE_TAG (&tag_e_async, dt->asynchronous); |
6de9cd9a | 3296 | |
44facdb7 FR |
3297 | /* Check I/O constraints. |
3298 | To validate NAMELIST we need to check if we were also given an I/O list, | |
3299 | which is stored in code->block->next with op EXEC_TRANSFER. | |
3300 | Note that the I/O list was already resolved from resolve_transfer. */ | |
3301 | gfc_code *io_code = NULL; | |
3302 | if (dt_code && dt_code->block && dt_code->block->next | |
3303 | && dt_code->block->next->op == EXEC_TRANSFER) | |
3304 | io_code = dt_code->block->next; | |
3305 | ||
3306 | if (!check_io_constraints (k, dt, io_code, loc)) | |
3307 | return false; | |
3308 | ||
6de9cd9a | 3309 | e = dt->io_unit; |
88e18fed JJ |
3310 | if (e == NULL) |
3311 | { | |
3312 | gfc_error ("UNIT not specified at %L", loc); | |
524af0d6 | 3313 | return false; |
88e18fed JJ |
3314 | } |
3315 | ||
b1be0054 JD |
3316 | if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER |
3317 | && e->ts.type == BT_CHARACTER) | |
3318 | { | |
3319 | gfc_error ("UNIT specification at %L must " | |
3320 | "not be a character PARAMETER", &e->where); | |
3321 | return false; | |
3322 | } | |
3323 | ||
524af0d6 | 3324 | if (gfc_resolve_expr (e) |
6de9cd9a | 3325 | && (e->ts.type != BT_INTEGER |
b251af97 | 3326 | && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE))) |
6de9cd9a | 3327 | { |
ad7ee6f8 JD |
3328 | /* If there is no extra comma signifying the "format" form of the IO |
3329 | statement, then this must be an error. */ | |
3330 | if (!dt->extra_comma) | |
3331 | { | |
3332 | gfc_error ("UNIT specification at %L must be an INTEGER expression " | |
3333 | "or a CHARACTER variable", &e->where); | |
524af0d6 | 3334 | return false; |
ad7ee6f8 JD |
3335 | } |
3336 | else | |
3337 | { | |
3338 | /* At this point, we have an extra comma. If io_unit has arrived as | |
df2fba9e | 3339 | type character, we assume its really the "format" form of the I/O |
ad7ee6f8 | 3340 | statement. We set the io_unit to the default unit and format to |
df2fba9e | 3341 | the character expression. See F95 Standard section 9.4. */ |
ad7ee6f8 JD |
3342 | if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) |
3343 | { | |
3344 | dt->format_expr = dt->io_unit; | |
3345 | dt->io_unit = default_unit (k); | |
3346 | ||
8e8dc060 DK |
3347 | /* Nullify this pointer now so that a warning/error is not |
3348 | triggered below for the "Extension". */ | |
ad7ee6f8 JD |
3349 | dt->extra_comma = NULL; |
3350 | } | |
3351 | ||
3352 | if (k == M_WRITE) | |
3353 | { | |
3354 | gfc_error ("Invalid form of WRITE statement at %L, UNIT required", | |
3355 | &dt->extra_comma->where); | |
524af0d6 | 3356 | return false; |
ad7ee6f8 JD |
3357 | } |
3358 | } | |
6de9cd9a DN |
3359 | } |
3360 | ||
6de9cd9a DN |
3361 | if (e->ts.type == BT_CHARACTER) |
3362 | { | |
4075a94e PT |
3363 | if (gfc_has_vector_index (e)) |
3364 | { | |
b251af97 | 3365 | gfc_error ("Internal unit with vector subscript at %L", &e->where); |
524af0d6 | 3366 | return false; |
4075a94e | 3367 | } |
8e8dc060 DK |
3368 | |
3369 | /* If we are writing, make sure the internal unit can be changed. */ | |
3370 | gcc_assert (k != M_PRINT); | |
3371 | if (k == M_WRITE | |
524af0d6 JB |
3372 | && !gfc_check_vardef_context (e, false, false, false, |
3373 | _("internal unit in WRITE"))) | |
3374 | return false; | |
e0e85e06 | 3375 | } |
4075a94e | 3376 | |
e0e85e06 PT |
3377 | if (e->rank && e->ts.type != BT_CHARACTER) |
3378 | { | |
3379 | gfc_error ("External IO UNIT cannot be an array at %L", &e->where); | |
524af0d6 | 3380 | return false; |
6de9cd9a DN |
3381 | } |
3382 | ||
9ad55c33 JD |
3383 | if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER |
3384 | && mpz_sgn (e->value.integer) < 0) | |
3385 | { | |
8e8dc060 DK |
3386 | gfc_error ("UNIT number in statement at %L must be non-negative", |
3387 | &e->where); | |
524af0d6 | 3388 | return false; |
9ad55c33 JD |
3389 | } |
3390 | ||
8e8dc060 DK |
3391 | /* If we are reading and have a namelist, check that all namelist symbols |
3392 | can appear in a variable definition context. */ | |
628c06d6 | 3393 | if (dt->namelist) |
8e8dc060 DK |
3394 | { |
3395 | gfc_namelist* n; | |
3396 | for (n = dt->namelist->namelist; n; n = n->next) | |
3397 | { | |
3398 | gfc_expr* e; | |
524af0d6 | 3399 | bool t; |
8e8dc060 | 3400 | |
628c06d6 JD |
3401 | if (k == M_READ) |
3402 | { | |
3403 | e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); | |
3404 | t = gfc_check_vardef_context (e, false, false, false, NULL); | |
3405 | gfc_free_expr (e); | |
3406 | ||
3407 | if (!t) | |
3408 | { | |
3409 | gfc_error ("NAMELIST %qs in READ statement at %L contains" | |
3410 | " the symbol %qs which may not appear in a" | |
3411 | " variable definition context", | |
3412 | dt->namelist->name, loc, n->sym->name); | |
3413 | return false; | |
3414 | } | |
3415 | } | |
8e8dc060 | 3416 | |
628c06d6 JD |
3417 | t = dtio_procs_present (n->sym, k); |
3418 | ||
3419 | if (n->sym->ts.type == BT_CLASS && !t) | |
8e8dc060 | 3420 | { |
628c06d6 JD |
3421 | gfc_error ("NAMELIST object %qs in namelist %qs at %L is " |
3422 | "polymorphic and requires a defined input/output " | |
3423 | "procedure", n->sym->name, dt->namelist->name, loc); | |
2263019d | 3424 | return false; |
628c06d6 JD |
3425 | } |
3426 | ||
3427 | if ((n->sym->ts.type == BT_DERIVED) | |
3428 | && (n->sym->ts.u.derived->attr.alloc_comp | |
3429 | || n->sym->ts.u.derived->attr.pointer_comp)) | |
3430 | { | |
3431 | if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " | |
3432 | "namelist %qs at %L with ALLOCATABLE " | |
3433 | "or POINTER components", n->sym->name, | |
3434 | dt->namelist->name, loc)) | |
2263019d | 3435 | return false; |
628c06d6 JD |
3436 | |
3437 | if (!t) | |
3438 | { | |
3439 | gfc_error ("NAMELIST object %qs in namelist %qs at %L has " | |
3440 | "ALLOCATABLE or POINTER components and thus requires " | |
3441 | "a defined input/output procedure", n->sym->name, | |
3442 | dt->namelist->name, loc); | |
2263019d | 3443 | return false; |
628c06d6 | 3444 | } |
8e8dc060 DK |
3445 | } |
3446 | } | |
3447 | } | |
3448 | ||
ad7ee6f8 | 3449 | if (dt->extra_comma |
d3dc025d | 3450 | && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L", |
524af0d6 JB |
3451 | &dt->extra_comma->where)) |
3452 | return false; | |
ad7ee6f8 | 3453 | |
e0e85e06 | 3454 | if (dt->err) |
6de9cd9a | 3455 | { |
524af0d6 JB |
3456 | if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET)) |
3457 | return false; | |
e0e85e06 | 3458 | if (dt->err->defined == ST_LABEL_UNKNOWN) |
6de9cd9a | 3459 | { |
e0e85e06 PT |
3460 | gfc_error ("ERR tag label %d at %L not defined", |
3461 | dt->err->value, &dt->err_where); | |
524af0d6 | 3462 | return false; |
6de9cd9a | 3463 | } |
e0e85e06 | 3464 | } |
6de9cd9a | 3465 | |
e0e85e06 PT |
3466 | if (dt->end) |
3467 | { | |
524af0d6 JB |
3468 | if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET)) |
3469 | return false; | |
e0e85e06 | 3470 | if (dt->end->defined == ST_LABEL_UNKNOWN) |
6de9cd9a | 3471 | { |
e0e85e06 PT |
3472 | gfc_error ("END tag label %d at %L not defined", |
3473 | dt->end->value, &dt->end_where); | |
524af0d6 | 3474 | return false; |
6de9cd9a | 3475 | } |
e0e85e06 | 3476 | } |
6de9cd9a | 3477 | |
e0e85e06 PT |
3478 | if (dt->eor) |
3479 | { | |
524af0d6 JB |
3480 | if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET)) |
3481 | return false; | |
e0e85e06 | 3482 | if (dt->eor->defined == ST_LABEL_UNKNOWN) |
6de9cd9a | 3483 | { |
e0e85e06 PT |
3484 | gfc_error ("EOR tag label %d at %L not defined", |
3485 | dt->eor->value, &dt->eor_where); | |
524af0d6 | 3486 | return false; |
6de9cd9a DN |
3487 | } |
3488 | } | |
3489 | ||
1f2959f0 | 3490 | /* Check the format label actually exists. */ |
6de9cd9a DN |
3491 | if (dt->format_label && dt->format_label != &format_asterisk |
3492 | && dt->format_label->defined == ST_LABEL_UNKNOWN) | |
3493 | { | |
3494 | gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value, | |
712dff31 | 3495 | loc); |
524af0d6 | 3496 | return false; |
6de9cd9a | 3497 | } |
8e8dc060 | 3498 | |
524af0d6 | 3499 | return true; |
6de9cd9a DN |
3500 | } |
3501 | ||
3502 | ||
3503 | /* Given an io_kind, return its name. */ | |
3504 | ||
3505 | static const char * | |
3506 | io_kind_name (io_kind k) | |
3507 | { | |
3508 | const char *name; | |
3509 | ||
3510 | switch (k) | |
3511 | { | |
3512 | case M_READ: | |
3513 | name = "READ"; | |
3514 | break; | |
3515 | case M_WRITE: | |
3516 | name = "WRITE"; | |
3517 | break; | |
3518 | case M_PRINT: | |
3519 | name = "PRINT"; | |
3520 | break; | |
3521 | case M_INQUIRE: | |
3522 | name = "INQUIRE"; | |
3523 | break; | |
3524 | default: | |
3525 | gfc_internal_error ("io_kind_name(): bad I/O-kind"); | |
3526 | } | |
3527 | ||
3528 | return name; | |
3529 | } | |
3530 | ||
3531 | ||
3532 | /* Match an IO iteration statement of the form: | |
3533 | ||
3534 | ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] ) | |
3535 | ||
3536 | which is equivalent to a single IO element. This function is | |
3537 | mutually recursive with match_io_element(). */ | |
3538 | ||
b251af97 | 3539 | static match match_io_element (io_kind, gfc_code **); |
6de9cd9a DN |
3540 | |
3541 | static match | |
b251af97 | 3542 | match_io_iterator (io_kind k, gfc_code **result) |
6de9cd9a | 3543 | { |
7b901ac4 | 3544 | gfc_code *head, *tail, *new_code; |
6de9cd9a DN |
3545 | gfc_iterator *iter; |
3546 | locus old_loc; | |
3547 | match m; | |
3548 | int n; | |
3549 | ||
3550 | iter = NULL; | |
3551 | head = NULL; | |
63645982 | 3552 | old_loc = gfc_current_locus; |
6de9cd9a DN |
3553 | |
3554 | if (gfc_match_char ('(') != MATCH_YES) | |
3555 | return MATCH_NO; | |
3556 | ||
3557 | m = match_io_element (k, &head); | |
3558 | tail = head; | |
3559 | ||
3560 | if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES) | |
3561 | { | |
3562 | m = MATCH_NO; | |
3563 | goto cleanup; | |
3564 | } | |
3565 | ||
3566 | /* Can't be anything but an IO iterator. Build a list. */ | |
3567 | iter = gfc_get_iterator (); | |
3568 | ||
3569 | for (n = 1;; n++) | |
3570 | { | |
3571 | m = gfc_match_iterator (iter, 0); | |
3572 | if (m == MATCH_ERROR) | |
3573 | goto cleanup; | |
3574 | if (m == MATCH_YES) | |
c9583ed2 TS |
3575 | { |
3576 | gfc_check_do_variable (iter->var->symtree); | |
3577 | break; | |
3578 | } | |
6de9cd9a | 3579 | |
7b901ac4 | 3580 | m = match_io_element (k, &new_code); |
6de9cd9a DN |
3581 | if (m == MATCH_ERROR) |
3582 | goto cleanup; | |
3583 | if (m == MATCH_NO) | |
3584 | { | |
3585 | if (n > 2) | |
3586 | goto syntax; | |
3587 | goto cleanup; | |
3588 | } | |
3589 | ||
7b901ac4 | 3590 | tail = gfc_append_code (tail, new_code); |
6de9cd9a DN |
3591 | |
3592 | if (gfc_match_char (',') != MATCH_YES) | |
3593 | { | |
3594 | if (n > 2) | |
3595 | goto syntax; | |
3596 | m = MATCH_NO; | |
3597 | goto cleanup; | |
3598 | } | |
3599 | } | |
3600 | ||
3601 | if (gfc_match_char (')') != MATCH_YES) | |
3602 | goto syntax; | |
3603 | ||
11e5274a | 3604 | new_code = gfc_get_code (EXEC_DO); |
7b901ac4 | 3605 | new_code->ext.iterator = iter; |
6de9cd9a | 3606 | |
11e5274a | 3607 | new_code->block = gfc_get_code (EXEC_DO); |
7b901ac4 | 3608 | new_code->block->next = head; |
6de9cd9a | 3609 | |
7b901ac4 | 3610 | *result = new_code; |
6de9cd9a DN |
3611 | return MATCH_YES; |
3612 | ||
3613 | syntax: | |
3614 | gfc_error ("Syntax error in I/O iterator at %C"); | |
3615 | m = MATCH_ERROR; | |
3616 | ||
3617 | cleanup: | |
3618 | gfc_free_iterator (iter, 1); | |
3619 | gfc_free_statements (head); | |
63645982 | 3620 | gfc_current_locus = old_loc; |
6de9cd9a DN |
3621 | return m; |
3622 | } | |
3623 | ||
3624 | ||
3625 | /* Match a single element of an IO list, which is either a single | |
3626 | expression or an IO Iterator. */ | |
3627 | ||
3628 | static match | |
b251af97 | 3629 | match_io_element (io_kind k, gfc_code **cpp) |
6de9cd9a DN |
3630 | { |
3631 | gfc_expr *expr; | |
3632 | gfc_code *cp; | |
3633 | match m; | |
3634 | ||
3635 | expr = NULL; | |
3636 | ||
3637 | m = match_io_iterator (k, cpp); | |
3638 | if (m == MATCH_YES) | |
3639 | return MATCH_YES; | |
3640 | ||
3641 | if (k == M_READ) | |
3642 | { | |
3643 | m = gfc_match_variable (&expr, 0); | |
3644 | if (m == MATCH_NO) | |
036aa592 SK |
3645 | { |
3646 | gfc_error ("Expecting variable in READ statement at %C"); | |
3647 | m = MATCH_ERROR; | |
3648 | } | |
3649 | ||
3650 | if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT) | |
3651 | { | |
3652 | gfc_error ("Expecting variable or io-implied-do in READ statement " | |
3653 | "at %L", &expr->where); | |
3654 | m = MATCH_ERROR; | |
3655 | } | |
5131b898 SK |
3656 | |
3657 | if (m == MATCH_YES | |
3658 | && expr->expr_type == EXPR_VARIABLE | |
3659 | && expr->symtree->n.sym->attr.external) | |
3660 | { | |
3661 | gfc_error ("Expecting variable or io-implied-do at %L", | |
3662 | &expr->where); | |
3663 | m = MATCH_ERROR; | |
3664 | } | |
6de9cd9a DN |
3665 | } |
3666 | else | |
3667 | { | |
3668 | m = gfc_match_expr (&expr); | |
3669 | if (m == MATCH_NO) | |
3670 | gfc_error ("Expected expression in %s statement at %C", | |
3671 | io_kind_name (k)); | |
4844a5cb SK |
3672 | |
3673 | if (m == MATCH_YES && expr->ts.type == BT_BOZ) | |
3674 | { | |
0a7183f6 ME |
3675 | if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in" |
3676 | " an output IO list"), &gfc_current_locus)) | |
4844a5cb SK |
3677 | return MATCH_ERROR; |
3678 | if (!gfc_boz2int (expr, gfc_max_integer_kind)) | |
3679 | return MATCH_ERROR; | |
3680 | }; | |
6de9cd9a DN |
3681 | } |
3682 | ||
8e8dc060 DK |
3683 | if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree)) |
3684 | m = MATCH_ERROR; | |
6de9cd9a DN |
3685 | |
3686 | if (m != MATCH_YES) | |
3687 | { | |
3688 | gfc_free_expr (expr); | |
3689 | return MATCH_ERROR; | |
3690 | } | |
3691 | ||
11e5274a | 3692 | cp = gfc_get_code (EXEC_TRANSFER); |
a513927a | 3693 | cp->expr1 = expr; |
70b9ed88 JD |
3694 | if (k != M_INQUIRE) |
3695 | cp->ext.dt = current_dt; | |
6de9cd9a DN |
3696 | |
3697 | *cpp = cp; | |
3698 | return MATCH_YES; | |
3699 | } | |
3700 | ||
3701 | ||
3702 | /* Match an I/O list, building gfc_code structures as we go. */ | |
3703 | ||
3704 | static match | |
b251af97 | 3705 | match_io_list (io_kind k, gfc_code **head_p) |
6de9cd9a | 3706 | { |
7b901ac4 | 3707 | gfc_code *head, *tail, *new_code; |
6de9cd9a DN |
3708 | match m; |
3709 | ||
3710 | *head_p = head = tail = NULL; | |
3711 | if (gfc_match_eos () == MATCH_YES) | |
3712 | return MATCH_YES; | |
3713 | ||
3714 | for (;;) | |
3715 | { | |
7b901ac4 | 3716 | m = match_io_element (k, &new_code); |
6de9cd9a DN |
3717 | if (m == MATCH_ERROR) |
3718 | goto cleanup; | |
3719 | if (m == MATCH_NO) | |
3720 | goto syntax; | |
3721 | ||
7b901ac4 | 3722 | tail = gfc_append_code (tail, new_code); |
6de9cd9a | 3723 | if (head == NULL) |
7b901ac4 | 3724 | head = new_code; |
6de9cd9a DN |
3725 | |
3726 | if (gfc_match_eos () == MATCH_YES) | |
3727 | break; | |
3728 | if (gfc_match_char (',') != MATCH_YES) | |
3729 | goto syntax; | |
3730 | } | |
3731 | ||
3732 | *head_p = head; | |
3733 | return MATCH_YES; | |
3734 | ||
3735 | syntax: | |
3736 | gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); | |
3737 | ||
3738 | cleanup: | |
3739 | gfc_free_statements (head); | |
3740 | return MATCH_ERROR; | |
3741 | } | |
3742 | ||
3743 | ||
3744 | /* Attach the data transfer end node. */ | |
3745 | ||
3746 | static void | |
b251af97 | 3747 | terminate_io (gfc_code *io_code) |
6de9cd9a DN |
3748 | { |
3749 | gfc_code *c; | |
3750 | ||
3751 | if (io_code == NULL) | |
5e805e44 | 3752 | io_code = new_st.block; |
6de9cd9a | 3753 | |
11e5274a | 3754 | c = gfc_get_code (EXEC_DT_END); |
6de9cd9a DN |
3755 | |
3756 | /* Point to structure that is already there */ | |
3757 | c->ext.dt = new_st.ext.dt; | |
3758 | gfc_append_code (io_code, c); | |
3759 | } | |
3760 | ||
3761 | ||
e0e85e06 | 3762 | /* Check the constraints for a data transfer statement. The majority of the |
44facdb7 | 3763 | constraints appearing in 9.4 of the standard appear here. |
e0e85e06 | 3764 | |
44facdb7 FR |
3765 | Tag expressions are already resolved by resolve_tag, which includes |
3766 | verifying the type, that they are scalar, and verifying that BT_CHARACTER | |
3767 | tags are of default kind. */ | |
3768 | ||
3769 | static bool | |
b251af97 SK |
3770 | check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, |
3771 | locus *spec_end) | |
e0e85e06 | 3772 | { |
a8416251 | 3773 | #define io_constraint(condition, msg, arg)\ |
e0e85e06 PT |
3774 | if (condition) \ |
3775 | {\ | |
a8416251 SK |
3776 | if ((arg)->lb != NULL)\ |
3777 | gfc_error ((msg), (arg));\ | |
3778 | else\ | |
44facdb7 FR |
3779 | gfc_error ((msg), spec_end);\ |
3780 | return false;\ | |
e0e85e06 PT |
3781 | } |
3782 | ||
b251af97 SK |
3783 | gfc_expr *expr; |
3784 | gfc_symbol *sym = NULL; | |
6f0f0b2e JD |
3785 | bool warn, unformatted; |
3786 | ||
3787 | warn = (dt->err || dt->iostat) ? true : false; | |
3788 | unformatted = dt->format_expr == NULL && dt->format_label == NULL | |
3789 | && dt->namelist == NULL; | |
e0e85e06 | 3790 | |
e0e85e06 PT |
3791 | expr = dt->io_unit; |
3792 | if (expr && expr->expr_type == EXPR_VARIABLE | |
b251af97 | 3793 | && expr->ts.type == BT_CHARACTER) |
e0e85e06 PT |
3794 | { |
3795 | sym = expr->symtree->n.sym; | |
3796 | ||
3797 | io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN, | |
3798 | "Internal file at %L must not be INTENT(IN)", | |
3799 | &expr->where); | |
3800 | ||
3801 | io_constraint (gfc_has_vector_index (dt->io_unit), | |
3802 | "Internal file incompatible with vector subscript at %L", | |
3803 | &expr->where); | |
3804 | ||
3805 | io_constraint (dt->rec != NULL, | |
3806 | "REC tag at %L is incompatible with internal file", | |
3807 | &dt->rec->where); | |
44facdb7 | 3808 | |
f5c64803 JD |
3809 | io_constraint (dt->pos != NULL, |
3810 | "POS tag at %L is incompatible with internal file", | |
3811 | &dt->pos->where); | |
e0e85e06 | 3812 | |
6f0f0b2e | 3813 | io_constraint (unformatted, |
89c32b0f TB |
3814 | "Unformatted I/O not allowed with internal unit at %L", |
3815 | &dt->io_unit->where); | |
3816 | ||
6f0f0b2e JD |
3817 | io_constraint (dt->asynchronous != NULL, |
3818 | "ASYNCHRONOUS tag at %L not allowed with internal file", | |
3819 | &dt->asynchronous->where); | |
3820 | ||
f1827a8c | 3821 | if (dt->namelist != NULL) |
b251af97 | 3822 | { |
524af0d6 JB |
3823 | if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " |
3824 | "namelist", &expr->where)) | |
44facdb7 | 3825 | return false; |
b251af97 | 3826 | } |
e0e85e06 PT |
3827 | |
3828 | io_constraint (dt->advance != NULL, | |
3829 | "ADVANCE tag at %L is incompatible with internal file", | |
3830 | &dt->advance->where); | |
3831 | } | |
3832 | ||
3833 | if (expr && expr->ts.type != BT_CHARACTER) | |
3834 | { | |
3835 | ||
a8416251 SK |
3836 | if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE)) |
3837 | { | |
44facdb7 | 3838 | gfc_error ("IO UNIT in %s statement at %L must be " |
e0e85e06 | 3839 | "an internal file in a PURE procedure", |
44facdb7 FR |
3840 | io_kind_name (k), &expr->where); |
3841 | return false; | |
a8416251 | 3842 | } |
44facdb7 | 3843 | |
9964e830 TB |
3844 | if (k == M_READ || k == M_WRITE) |
3845 | gfc_unset_implicit_pure (NULL); | |
e0e85e06 PT |
3846 | } |
3847 | ||
44facdb7 | 3848 | if (dt->asynchronous) |
6f0f0b2e | 3849 | { |
27594524 | 3850 | int num = -1; |
6f0f0b2e JD |
3851 | static const char * asynchronous[] = { "YES", "NO", NULL }; |
3852 | ||
44facdb7 | 3853 | /* Note: gfc_reduce_init_expr reports an error if not init-expr. */ |
524af0d6 | 3854 | if (!gfc_reduce_init_expr (dt->asynchronous)) |
44facdb7 | 3855 | return false; |
87550b74 | 3856 | |
6f0f0b2e JD |
3857 | if (!compare_to_allowed_values |
3858 | ("ASYNCHRONOUS", asynchronous, NULL, NULL, | |
3859 | dt->asynchronous->value.character.string, | |
44facdb7 FR |
3860 | io_kind_name (k), warn, &dt->asynchronous->where, &num)) |
3861 | return false; | |
a4792d44 | 3862 | |
27594524 SSF |
3863 | gcc_checking_assert (num != -1); |
3864 | ||
44facdb7 FR |
3865 | /* For "YES", mark related symbols as asynchronous. */ |
3866 | if (num == 0) | |
3867 | { | |
3868 | /* SIZE variable. */ | |
3869 | if (dt->size) | |
3870 | dt->size->symtree->n.sym->attr.asynchronous = 1; | |
3871 | ||
3872 | /* Variables in a NAMELIST. */ | |
3873 | if (dt->namelist) | |
3874 | for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next) | |
3875 | nl->sym->attr.asynchronous = 1; | |
3876 | ||
3877 | /* Variables in an I/O list. */ | |
3878 | for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER; | |
3879 | xfer = xfer->next) | |
3880 | { | |
3881 | gfc_expr *expr = xfer->expr1; | |
3882 | while (expr != NULL && expr->expr_type == EXPR_OP | |
3883 | && expr->value.op.op == INTRINSIC_PARENTHESES) | |
3884 | expr = expr->value.op.op1; | |
3885 | ||
3886 | if (expr && expr->expr_type == EXPR_VARIABLE) | |
3887 | expr->symtree->n.sym->attr.asynchronous = 1; | |
3888 | } | |
3889 | } | |
6f0f0b2e JD |
3890 | } |
3891 | ||
3892 | if (dt->id) | |
3893 | { | |
00660189 FXC |
3894 | bool not_yes |
3895 | = !dt->asynchronous | |
3896 | || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 | |
3897 | || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, | |
3898 | "yes", 3) != 0; | |
3899 | io_constraint (not_yes, | |
d06b3496 | 3900 | "ID= specifier at %L must be with ASYNCHRONOUS='yes' " |
6f0f0b2e JD |
3901 | "specifier", &dt->id->where); |
3902 | } | |
3903 | ||
3904 | if (dt->decimal) | |
3905 | { | |
44facdb7 FR |
3906 | if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " |
3907 | "not allowed in Fortran 95", &dt->decimal->where)) | |
3908 | return false; | |
6f0f0b2e JD |
3909 | |
3910 | if (dt->decimal->expr_type == EXPR_CONSTANT) | |
3911 | { | |
3912 | static const char * decimal[] = { "COMMA", "POINT", NULL }; | |
3913 | ||
3914 | if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, | |
3915 | dt->decimal->value.character.string, | |
44facdb7 FR |
3916 | io_kind_name (k), warn, |
3917 | &dt->decimal->where)) | |
3918 | return false; | |
6f0f0b2e JD |
3919 | |
3920 | io_constraint (unformatted, | |
d06b3496 | 3921 | "the DECIMAL= specifier at %L must be with an " |
6f0f0b2e JD |
3922 | "explicit format expression", &dt->decimal->where); |
3923 | } | |
3924 | } | |
44facdb7 | 3925 | |
6f0f0b2e JD |
3926 | if (dt->blank) |
3927 | { | |
44facdb7 FR |
3928 | if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " |
3929 | "not allowed in Fortran 95", &dt->blank->where)) | |
3930 | return false; | |
2e431643 | 3931 | |
6f0f0b2e JD |
3932 | if (dt->blank->expr_type == EXPR_CONSTANT) |
3933 | { | |
3934 | static const char * blank[] = { "NULL", "ZERO", NULL }; | |
3935 | ||
2e431643 | 3936 | |
6f0f0b2e JD |
3937 | if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, |
3938 | dt->blank->value.character.string, | |
44facdb7 FR |
3939 | io_kind_name (k), warn, |
3940 | &dt->blank->where)) | |
3941 | return false; | |
6f0f0b2e JD |
3942 | |
3943 | io_constraint (unformatted, | |
d06b3496 | 3944 | "the BLANK= specifier at %L must be with an " |
6f0f0b2e JD |
3945 | "explicit format expression", &dt->blank->where); |
3946 | } | |
3947 | } | |
3948 | ||
3949 | if (dt->pad) | |
3950 | { | |
44facdb7 FR |
3951 | if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L " |
3952 | "not allowed in Fortran 95", &dt->pad->where)) | |
3953 | return false; | |
2e431643 | 3954 | |
6f0f0b2e JD |
3955 | if (dt->pad->expr_type == EXPR_CONSTANT) |
3956 | { | |
3957 | static const char * pad[] = { "YES", "NO", NULL }; | |
3958 | ||
3959 | if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, | |
3960 | dt->pad->value.character.string, | |
44facdb7 FR |
3961 | io_kind_name (k), warn, |
3962 | &dt->pad->where)) | |
3963 | return false; | |
6f0f0b2e JD |
3964 | |
3965 | io_constraint (unformatted, | |
d06b3496 | 3966 | "the PAD= specifier at %L must be with an " |
6f0f0b2e JD |
3967 | "explicit format expression", &dt->pad->where); |
3968 | } | |
3969 | } | |
3970 | ||
3971 | if (dt->round) | |
3972 | { | |
44facdb7 FR |
3973 | if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " |
3974 | "not allowed in Fortran 95", &dt->round->where)) | |
3975 | return false; | |
2e431643 | 3976 | |
6f0f0b2e JD |
3977 | if (dt->round->expr_type == EXPR_CONSTANT) |
3978 | { | |
3979 | static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", | |
3980 | "COMPATIBLE", "PROCESSOR_DEFINED", | |
3981 | NULL }; | |
3982 | ||
3983 | if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, | |
3984 | dt->round->value.character.string, | |
44facdb7 FR |
3985 | io_kind_name (k), warn, |
3986 | &dt->round->where)) | |
3987 | return false; | |
6f0f0b2e JD |
3988 | } |
3989 | } | |
44facdb7 | 3990 | |
6f0f0b2e JD |
3991 | if (dt->sign) |
3992 | { | |
3993 | /* When implemented, change the following to use gfc_notify_std F2003. | |
44facdb7 FR |
3994 | if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " |
3995 | "not allowed in Fortran 95", &dt->sign->where) == false) | |
3996 | return false; */ | |
2e431643 | 3997 | |
6f0f0b2e JD |
3998 | if (dt->sign->expr_type == EXPR_CONSTANT) |
3999 | { | |
4000 | static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", | |
4001 | NULL }; | |
4002 | ||
4003 | if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, | |
4004 | dt->sign->value.character.string, | |
44facdb7 FR |
4005 | io_kind_name (k), warn, &dt->sign->where)) |
4006 | return false; | |
6f0f0b2e JD |
4007 | |
4008 | io_constraint (unformatted, | |
d06b3496 | 4009 | "SIGN= specifier at %L must be with an " |
6f0f0b2e | 4010 | "explicit format expression", &dt->sign->where); |
e0e85e06 | 4011 | |
6f0f0b2e | 4012 | io_constraint (k == M_READ, |
d06b3496 | 4013 | "SIGN= specifier at %L not allowed in a " |
6f0f0b2e JD |
4014 | "READ statement", &dt->sign->where); |
4015 | } | |
4016 | } | |
4017 | ||
4018 | if (dt->delim) | |
4019 | { | |
44facdb7 FR |
4020 | if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L " |
4021 | "not allowed in Fortran 95", &dt->delim->where)) | |
4022 | return false; | |
2e431643 | 4023 | |
6f0f0b2e JD |
4024 | if (dt->delim->expr_type == EXPR_CONSTANT) |
4025 | { | |
4026 | static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; | |
4027 | ||
4028 | if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, | |
4029 | dt->delim->value.character.string, | |
44facdb7 FR |
4030 | io_kind_name (k), warn, |
4031 | &dt->delim->where)) | |
4032 | return false; | |
6f0f0b2e JD |
4033 | |
4034 | io_constraint (k == M_READ, | |
d06b3496 | 4035 | "DELIM= specifier at %L not allowed in a " |
6f0f0b2e | 4036 | "READ statement", &dt->delim->where); |
44facdb7 | 4037 | |
6f0f0b2e JD |
4038 | io_constraint (dt->format_label != &format_asterisk |
4039 | && dt->namelist == NULL, | |
d06b3496 | 4040 | "DELIM= specifier at %L must have FMT=*", |
6f0f0b2e JD |
4041 | &dt->delim->where); |
4042 | ||
4043 | io_constraint (unformatted && dt->namelist == NULL, | |
d06b3496 | 4044 | "DELIM= specifier at %L must be with FMT=* or " |
2f029c08 | 4045 | "NML= specifier", &dt->delim->where); |
6f0f0b2e JD |
4046 | } |
4047 | } | |
44facdb7 | 4048 | |
e0e85e06 PT |
4049 | if (dt->namelist) |
4050 | { | |
4051 | io_constraint (io_code && dt->namelist, | |
4052 | "NAMELIST cannot be followed by IO-list at %L", | |
4053 | &io_code->loc); | |
4054 | ||
4055 | io_constraint (dt->format_expr, | |
4056 | "IO spec-list cannot contain both NAMELIST group name " | |
f5c64803 | 4057 | "and format specification at %L", |
e0e85e06 PT |
4058 | &dt->format_expr->where); |
4059 | ||
4060 | io_constraint (dt->format_label, | |
4061 | "IO spec-list cannot contain both NAMELIST group name " | |
4062 | "and format label at %L", spec_end); | |
4063 | ||
4064 | io_constraint (dt->rec, | |
d06b3496 | 4065 | "NAMELIST IO is not allowed with a REC= specifier " |
f5c64803 | 4066 | "at %L", &dt->rec->where); |
e0e85e06 PT |
4067 | |
4068 | io_constraint (dt->advance, | |
d06b3496 | 4069 | "NAMELIST IO is not allowed with a ADVANCE= specifier " |
f5c64803 | 4070 | "at %L", &dt->advance->where); |
e0e85e06 PT |
4071 | } |
4072 | ||
4073 | if (dt->rec) | |
4074 | { | |
4075 | io_constraint (dt->end, | |
4076 | "An END tag is not allowed with a " | |
f5c64803 | 4077 | "REC= specifier at %L", &dt->end_where); |
e0e85e06 | 4078 | |
e0e85e06 | 4079 | io_constraint (dt->format_label == &format_asterisk, |
d06b3496 | 4080 | "FMT=* is not allowed with a REC= specifier " |
f5c64803 JD |
4081 | "at %L", spec_end); |
4082 | ||
4083 | io_constraint (dt->pos, | |
4084 | "POS= is not allowed with REC= specifier " | |
4085 | "at %L", &dt->pos->where); | |
e0e85e06 PT |
4086 | } |
4087 | ||
4088 | if (dt->advance) | |
4089 | { | |
e0e85e06 PT |
4090 | int not_yes, not_no; |
4091 | expr = dt->advance; | |
e0e85e06 PT |
4092 | |
4093 | io_constraint (dt->format_label == &format_asterisk, | |
4094 | "List directed format(*) is not allowed with a " | |
d06b3496 | 4095 | "ADVANCE= specifier at %L.", &expr->where); |
e0e85e06 | 4096 | |
6f0f0b2e | 4097 | io_constraint (unformatted, |
d06b3496 | 4098 | "the ADVANCE= specifier at %L must appear with an " |
b8ea6dbc PT |
4099 | "explicit format expression", &expr->where); |
4100 | ||
8370d5bc JJ |
4101 | if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) |
4102 | { | |
00660189 FXC |
4103 | const gfc_char_t *advance = expr->value.character.string; |
4104 | not_no = gfc_wide_strlen (advance) != 2 | |
4105 | || gfc_wide_strncasecmp (advance, "no", 2) != 0; | |
4106 | not_yes = gfc_wide_strlen (advance) != 3 | |
4107 | || gfc_wide_strncasecmp (advance, "yes", 3) != 0; | |
8370d5bc JJ |
4108 | } |
4109 | else | |
4110 | { | |
4111 | not_no = 0; | |
4112 | not_yes = 0; | |
4113 | } | |
e0e85e06 | 4114 | |
8370d5bc | 4115 | io_constraint (not_no && not_yes, |
d06b3496 | 4116 | "ADVANCE= specifier at %L must have value = " |
e0e85e06 PT |
4117 | "YES or NO.", &expr->where); |
4118 | ||
8370d5bc | 4119 | io_constraint (dt->size && not_no && k == M_READ, |
a4d9b221 | 4120 | "SIZE tag at %L requires an ADVANCE = %<NO%>", |
e0e85e06 PT |
4121 | &dt->size->where); |
4122 | ||
8370d5bc | 4123 | io_constraint (dt->eor && not_no && k == M_READ, |
a4d9b221 | 4124 | "EOR tag at %L requires an ADVANCE = %<NO%>", |
44facdb7 | 4125 | &dt->eor_where); |
e0e85e06 PT |
4126 | } |
4127 | ||
44facdb7 FR |
4128 | if (k != M_READ) |
4129 | { | |
4130 | io_constraint (dt->end, "END tag not allowed with output at %L", | |
4131 | &dt->end_where); | |
e0e85e06 | 4132 | |
44facdb7 FR |
4133 | io_constraint (dt->eor, "EOR tag not allowed with output at %L", |
4134 | &dt->eor_where); | |
4135 | ||
4136 | io_constraint (dt->blank, | |
4137 | "BLANK= specifier not allowed with output at %L", | |
4138 | &dt->blank->where); | |
4139 | ||
4140 | io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", | |
4141 | &dt->pad->where); | |
4142 | ||
4143 | io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", | |
4144 | &dt->size->where); | |
4145 | } | |
4146 | else | |
4147 | { | |
4148 | io_constraint (dt->size && dt->advance == NULL, | |
4149 | "SIZE tag at %L requires an ADVANCE tag", | |
4150 | &dt->size->where); | |
4151 | ||
4152 | io_constraint (dt->eor && dt->advance == NULL, | |
4153 | "EOR tag at %L requires an ADVANCE tag", | |
4154 | &dt->eor_where); | |
4155 | } | |
4156 | ||
4157 | return true; | |
e0e85e06 | 4158 | #undef io_constraint |
44facdb7 | 4159 | } |
e0e85e06 | 4160 | |
b251af97 | 4161 | |
6de9cd9a DN |
4162 | /* Match a READ, WRITE or PRINT statement. */ |
4163 | ||
4164 | static match | |
4165 | match_io (io_kind k) | |
4166 | { | |
4167 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
4168 | gfc_code *io_code; | |
4169 | gfc_symbol *sym; | |
8fc541d3 | 4170 | int comma_flag; |
6de9cd9a | 4171 | locus where; |
44facdb7 | 4172 | locus control; |
6de9cd9a DN |
4173 | gfc_dt *dt; |
4174 | match m; | |
4175 | ||
e0e85e06 | 4176 | where = gfc_current_locus; |
6de9cd9a | 4177 | comma_flag = 0; |
ece3f663 | 4178 | current_dt = dt = XCNEW (gfc_dt); |
ff2c6bbb SK |
4179 | m = gfc_match_char ('('); |
4180 | if (m == MATCH_NO) | |
6de9cd9a | 4181 | { |
7fd4d312 | 4182 | where = gfc_current_locus; |
08e1fe9e TS |
4183 | if (k == M_WRITE) |
4184 | goto syntax; | |
7fd4d312 | 4185 | else if (k == M_PRINT) |
7af8f00c | 4186 | { |
08e1fe9e | 4187 | /* Treat the non-standard case of PRINT namelist. */ |
8fc541d3 | 4188 | if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') |
7fd4d312 | 4189 | && gfc_match_name (name) == MATCH_YES) |
7af8f00c | 4190 | { |
7fd4d312 TS |
4191 | gfc_find_symbol (name, NULL, 1, &sym); |
4192 | if (sym && sym->attr.flavor == FL_NAMELIST) | |
08e1fe9e | 4193 | { |
524af0d6 JB |
4194 | if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at " |
4195 | "%C is an extension")) | |
7fd4d312 TS |
4196 | { |
4197 | m = MATCH_ERROR; | |
4198 | goto cleanup; | |
4199 | } | |
7fd4d312 TS |
4200 | |
4201 | dt->io_unit = default_unit (k); | |
4202 | dt->namelist = sym; | |
4203 | goto get_io_list; | |
08e1fe9e | 4204 | } |
7fd4d312 TS |
4205 | else |
4206 | gfc_current_locus = where; | |
08e1fe9e | 4207 | } |
474175e9 JD |
4208 | |
4209 | if (gfc_match_char ('*') == MATCH_YES | |
4210 | && gfc_match_char(',') == MATCH_YES) | |
4211 | { | |
4212 | locus where2 = gfc_current_locus; | |
4213 | if (gfc_match_eos () == MATCH_YES) | |
4214 | { | |
4215 | gfc_current_locus = where2; | |
4216 | gfc_error ("Comma after * at %C not allowed without I/O list"); | |
4217 | m = MATCH_ERROR; | |
4218 | goto cleanup; | |
4219 | } | |
4220 | else | |
4221 | gfc_current_locus = where; | |
4222 | } | |
4223 | else | |
4224 | gfc_current_locus = where; | |
7af8f00c PT |
4225 | } |
4226 | ||
0ff0dfbf | 4227 | if (gfc_current_form == FORM_FREE) |
7fd4d312 | 4228 | { |
8fc541d3 | 4229 | char c = gfc_peek_ascii_char (); |
7fd4d312 TS |
4230 | if (c != ' ' && c != '*' && c != '\'' && c != '"') |
4231 | { | |
4232 | m = MATCH_NO; | |
4233 | goto cleanup; | |
4234 | } | |
4235 | } | |
0ff0dfbf | 4236 | |
6de9cd9a DN |
4237 | m = match_dt_format (dt); |
4238 | if (m == MATCH_ERROR) | |
4239 | goto cleanup; | |
4240 | if (m == MATCH_NO) | |
4241 | goto syntax; | |
4242 | ||
4243 | comma_flag = 1; | |
4244 | dt->io_unit = default_unit (k); | |
4245 | goto get_io_list; | |
4246 | } | |
4d08533c TK |
4247 | else |
4248 | { | |
ff2c6bbb SK |
4249 | /* Before issuing an error for a malformed 'print (1,*)' type of |
4250 | error, check for a default-char-expr of the form ('(I0)'). */ | |
4731c9f0 JD |
4251 | if (m == MATCH_YES) |
4252 | { | |
4253 | control = gfc_current_locus; | |
4254 | if (k == M_PRINT) | |
4255 | { | |
4256 | /* Reset current locus to get the initial '(' in an expression. */ | |
4257 | gfc_current_locus = where; | |
4258 | dt->format_expr = NULL; | |
4259 | m = match_dt_format (dt); | |
ff2c6bbb | 4260 | |
4731c9f0 JD |
4261 | if (m == MATCH_ERROR) |
4262 | goto cleanup; | |
4263 | if (m == MATCH_NO || dt->format_expr == NULL) | |
4264 | goto syntax; | |
ff2c6bbb | 4265 | |
4731c9f0 JD |
4266 | comma_flag = 1; |
4267 | dt->io_unit = default_unit (k); | |
4268 | goto get_io_list; | |
4269 | } | |
4270 | if (k == M_READ) | |
4271 | { | |
bc720937 JD |
4272 | /* Commit any pending symbols now so that when we undo |
4273 | symbols later we wont lose them. */ | |
4274 | gfc_commit_symbols (); | |
4731c9f0 JD |
4275 | /* Reset current locus to get the initial '(' in an expression. */ |
4276 | gfc_current_locus = where; | |
4277 | dt->format_expr = NULL; | |
4278 | m = gfc_match_expr (&dt->format_expr); | |
4279 | if (m == MATCH_YES) | |
4280 | { | |
4281 | if (dt->format_expr | |
4282 | && dt->format_expr->ts.type == BT_CHARACTER) | |
4283 | { | |
4284 | comma_flag = 1; | |
4285 | dt->io_unit = default_unit (k); | |
4286 | goto get_io_list; | |
4287 | } | |
4288 | else | |
4289 | { | |
4290 | gfc_free_expr (dt->format_expr); | |
4291 | dt->format_expr = NULL; | |
4292 | gfc_current_locus = control; | |
4293 | } | |
4294 | } | |
4295 | else | |
4296 | { | |
4297 | gfc_clear_error (); | |
4298 | gfc_undo_symbols (); | |
4299 | gfc_free_expr (dt->format_expr); | |
4300 | dt->format_expr = NULL; | |
4301 | gfc_current_locus = control; | |
4302 | } | |
4303 | } | |
ff2c6bbb | 4304 | } |
4d08533c | 4305 | } |
6de9cd9a DN |
4306 | |
4307 | /* Match a control list */ | |
4308 | if (match_dt_element (k, dt) == MATCH_YES) | |
4309 | goto next; | |
4310 | if (match_dt_unit (k, dt) != MATCH_YES) | |
4311 | goto loop; | |
4312 | ||
4313 | if (gfc_match_char (')') == MATCH_YES) | |
4314 | goto get_io_list; | |
4315 | if (gfc_match_char (',') != MATCH_YES) | |
4316 | goto syntax; | |
4317 | ||
4318 | m = match_dt_element (k, dt); | |
4319 | if (m == MATCH_YES) | |
4320 | goto next; | |
4321 | if (m == MATCH_ERROR) | |
4322 | goto cleanup; | |
4323 | ||
4324 | m = match_dt_format (dt); | |
4325 | if (m == MATCH_YES) | |
4326 | goto next; | |
4327 | if (m == MATCH_ERROR) | |
4328 | goto cleanup; | |
4329 | ||
63645982 | 4330 | where = gfc_current_locus; |
6de9cd9a | 4331 | |
7fd4d312 TS |
4332 | m = gfc_match_name (name); |
4333 | if (m == MATCH_YES) | |
6de9cd9a | 4334 | { |
7fd4d312 TS |
4335 | gfc_find_symbol (name, NULL, 1, &sym); |
4336 | if (sym && sym->attr.flavor == FL_NAMELIST) | |
6de9cd9a | 4337 | { |
7fd4d312 TS |
4338 | dt->namelist = sym; |
4339 | if (k == M_READ && check_namelist (sym)) | |
4340 | { | |
4341 | m = MATCH_ERROR; | |
4342 | goto cleanup; | |
4343 | } | |
4344 | goto next; | |
6de9cd9a | 4345 | } |
6de9cd9a DN |
4346 | } |
4347 | ||
63645982 | 4348 | gfc_current_locus = where; |
6de9cd9a DN |
4349 | |
4350 | goto loop; /* No matches, try regular elements */ | |
4351 | ||
4352 | next: | |
4353 | if (gfc_match_char (')') == MATCH_YES) | |
4354 | goto get_io_list; | |
4355 | if (gfc_match_char (',') != MATCH_YES) | |
4356 | goto syntax; | |
4357 | ||
4358 | loop: | |
4359 | for (;;) | |
4360 | { | |
4361 | m = match_dt_element (k, dt); | |
4362 | if (m == MATCH_NO) | |
4363 | goto syntax; | |
4364 | if (m == MATCH_ERROR) | |
4365 | goto cleanup; | |
4366 | ||
4367 | if (gfc_match_char (')') == MATCH_YES) | |
4368 | break; | |
4369 | if (gfc_match_char (',') != MATCH_YES) | |
4370 | goto syntax; | |
4371 | } | |
4372 | ||
4373 | get_io_list: | |
e0e85e06 | 4374 | |
8e8dc060 DK |
4375 | /* Save the IO kind for later use. */ |
4376 | dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); | |
4377 | ||
ad7ee6f8 JD |
4378 | /* Optional leading comma (non-standard). We use a gfc_expr structure here |
4379 | to save the locus. This is used later when resolving transfer statements | |
4380 | that might have a format expression without unit number. */ | |
4381 | if (!comma_flag && gfc_match_char (',') == MATCH_YES) | |
8e8dc060 | 4382 | dt->extra_comma = dt->dt_io_kind; |
6de9cd9a DN |
4383 | |
4384 | io_code = NULL; | |
4385 | if (gfc_match_eos () != MATCH_YES) | |
4386 | { | |
4387 | if (comma_flag && gfc_match_char (',') != MATCH_YES) | |
4388 | { | |
4389 | gfc_error ("Expected comma in I/O list at %C"); | |
4390 | m = MATCH_ERROR; | |
4391 | goto cleanup; | |
4392 | } | |
4393 | ||
4394 | m = match_io_list (k, &io_code); | |
4395 | if (m == MATCH_ERROR) | |
4396 | goto cleanup; | |
4397 | if (m == MATCH_NO) | |
4398 | goto syntax; | |
4399 | } | |
4400 | ||
7ee4f6f3 | 4401 | /* See if we want to use defaults for missing exponents in real transfers |
88a8126a JB |
4402 | and other DEC runtime extensions. */ |
4403 | if (flag_dec_format_defaults) | |
7ee4f6f3 | 4404 | dt->dec_ext = 1; |
6869e9c6 | 4405 | |
44facdb7 FR |
4406 | /* Check the format string now. */ |
4407 | if (dt->format_expr | |
4408 | && (!gfc_simplify_expr (dt->format_expr, 0) | |
4409 | || !check_format_string (dt->format_expr, k == M_READ))) | |
4410 | return MATCH_ERROR; | |
6de9cd9a DN |
4411 | |
4412 | new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; | |
4413 | new_st.ext.dt = dt; | |
11e5274a | 4414 | new_st.block = gfc_get_code (new_st.op); |
5e805e44 | 4415 | new_st.block->next = io_code; |
6de9cd9a DN |
4416 | |
4417 | terminate_io (io_code); | |
4418 | ||
4419 | return MATCH_YES; | |
4420 | ||
4421 | syntax: | |
4422 | gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); | |
4423 | m = MATCH_ERROR; | |
4424 | ||
4425 | cleanup: | |
4426 | gfc_free_dt (dt); | |
4427 | return m; | |
4428 | } | |
4429 | ||
4430 | ||
4431 | match | |
4432 | gfc_match_read (void) | |
4433 | { | |
4434 | return match_io (M_READ); | |
4435 | } | |
4436 | ||
6f0f0b2e | 4437 | |
6de9cd9a DN |
4438 | match |
4439 | gfc_match_write (void) | |
4440 | { | |
4441 | return match_io (M_WRITE); | |
4442 | } | |
4443 | ||
6f0f0b2e | 4444 | |
6de9cd9a DN |
4445 | match |
4446 | gfc_match_print (void) | |
4447 | { | |
4448 | match m; | |
4449 | ||
4450 | m = match_io (M_PRINT); | |
4451 | if (m != MATCH_YES) | |
4452 | return m; | |
4453 | ||
4454 | if (gfc_pure (NULL)) | |
4455 | { | |
4456 | gfc_error ("PRINT statement at %C not allowed within PURE procedure"); | |
4457 | return MATCH_ERROR; | |
4458 | } | |
4459 | ||
ccd7751b | 4460 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 4461 | |
6de9cd9a DN |
4462 | return MATCH_YES; |
4463 | } | |
4464 | ||
4465 | ||
4466 | /* Free a gfc_inquire structure. */ | |
4467 | ||
4468 | void | |
b251af97 | 4469 | gfc_free_inquire (gfc_inquire *inquire) |
6de9cd9a DN |
4470 | { |
4471 | ||
4472 | if (inquire == NULL) | |
4473 | return; | |
4474 | ||
4475 | gfc_free_expr (inquire->unit); | |
4476 | gfc_free_expr (inquire->file); | |
7aba8abe | 4477 | gfc_free_expr (inquire->iomsg); |
6de9cd9a DN |
4478 | gfc_free_expr (inquire->iostat); |
4479 | gfc_free_expr (inquire->exist); | |
4480 | gfc_free_expr (inquire->opened); | |
4481 | gfc_free_expr (inquire->number); | |
4482 | gfc_free_expr (inquire->named); | |
4483 | gfc_free_expr (inquire->name); | |
4484 | gfc_free_expr (inquire->access); | |
4485 | gfc_free_expr (inquire->sequential); | |
4486 | gfc_free_expr (inquire->direct); | |
4487 | gfc_free_expr (inquire->form); | |
4488 | gfc_free_expr (inquire->formatted); | |
4489 | gfc_free_expr (inquire->unformatted); | |
4490 | gfc_free_expr (inquire->recl); | |
4491 | gfc_free_expr (inquire->nextrec); | |
4492 | gfc_free_expr (inquire->blank); | |
4493 | gfc_free_expr (inquire->position); | |
4494 | gfc_free_expr (inquire->action); | |
4495 | gfc_free_expr (inquire->read); | |
4496 | gfc_free_expr (inquire->write); | |
4497 | gfc_free_expr (inquire->readwrite); | |
4498 | gfc_free_expr (inquire->delim); | |
d06b3496 | 4499 | gfc_free_expr (inquire->encoding); |
6de9cd9a DN |
4500 | gfc_free_expr (inquire->pad); |
4501 | gfc_free_expr (inquire->iolength); | |
181c9f4a | 4502 | gfc_free_expr (inquire->convert); |
014ec6ee | 4503 | gfc_free_expr (inquire->strm_pos); |
d06b3496 | 4504 | gfc_free_expr (inquire->asynchronous); |
e1456843 | 4505 | gfc_free_expr (inquire->decimal); |
d06b3496 JD |
4506 | gfc_free_expr (inquire->pending); |
4507 | gfc_free_expr (inquire->id); | |
4508 | gfc_free_expr (inquire->sign); | |
e1456843 | 4509 | gfc_free_expr (inquire->size); |
d06b3496 | 4510 | gfc_free_expr (inquire->round); |
0ef33d44 FR |
4511 | gfc_free_expr (inquire->share); |
4512 | gfc_free_expr (inquire->cc); | |
cede9502 | 4513 | free (inquire); |
6de9cd9a DN |
4514 | } |
4515 | ||
4516 | ||
4517 | /* Match an element of an INQUIRE statement. */ | |
4518 | ||
4519 | #define RETM if (m != MATCH_NO) return m; | |
4520 | ||
4521 | static match | |
b251af97 | 4522 | match_inquire_element (gfc_inquire *inquire) |
6de9cd9a DN |
4523 | { |
4524 | match m; | |
4525 | ||
4526 | m = match_etag (&tag_unit, &inquire->unit); | |
4527 | RETM m = match_etag (&tag_file, &inquire->file); | |
4528 | RETM m = match_ltag (&tag_err, &inquire->err); | |
fd5cabb2 | 4529 | RETM m = match_etag (&tag_iomsg, &inquire->iomsg); |
c9583ed2 | 4530 | RETM m = match_out_tag (&tag_iostat, &inquire->iostat); |
6de9cd9a DN |
4531 | RETM m = match_vtag (&tag_exist, &inquire->exist); |
4532 | RETM m = match_vtag (&tag_opened, &inquire->opened); | |
4533 | RETM m = match_vtag (&tag_named, &inquire->named); | |
4534 | RETM m = match_vtag (&tag_name, &inquire->name); | |
c9583ed2 | 4535 | RETM m = match_out_tag (&tag_number, &inquire->number); |
6de9cd9a DN |
4536 | RETM m = match_vtag (&tag_s_access, &inquire->access); |
4537 | RETM m = match_vtag (&tag_sequential, &inquire->sequential); | |
4538 | RETM m = match_vtag (&tag_direct, &inquire->direct); | |
4539 | RETM m = match_vtag (&tag_s_form, &inquire->form); | |
4540 | RETM m = match_vtag (&tag_formatted, &inquire->formatted); | |
4541 | RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); | |
c9583ed2 TS |
4542 | RETM m = match_out_tag (&tag_s_recl, &inquire->recl); |
4543 | RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec); | |
6de9cd9a DN |
4544 | RETM m = match_vtag (&tag_s_blank, &inquire->blank); |
4545 | RETM m = match_vtag (&tag_s_position, &inquire->position); | |
4546 | RETM m = match_vtag (&tag_s_action, &inquire->action); | |
4547 | RETM m = match_vtag (&tag_read, &inquire->read); | |
4548 | RETM m = match_vtag (&tag_write, &inquire->write); | |
4549 | RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); | |
d06b3496 | 4550 | RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); |
6de9cd9a | 4551 | RETM m = match_vtag (&tag_s_delim, &inquire->delim); |
d06b3496 | 4552 | RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); |
92867546 | 4553 | RETM m = match_out_tag (&tag_size, &inquire->size); |
d06b3496 JD |
4554 | RETM m = match_vtag (&tag_s_encoding, &inquire->encoding); |
4555 | RETM m = match_vtag (&tag_s_round, &inquire->round); | |
4556 | RETM m = match_vtag (&tag_s_sign, &inquire->sign); | |
6de9cd9a | 4557 | RETM m = match_vtag (&tag_s_pad, &inquire->pad); |
92867546 | 4558 | RETM m = match_out_tag (&tag_iolength, &inquire->iolength); |
181c9f4a | 4559 | RETM m = match_vtag (&tag_convert, &inquire->convert); |
014ec6ee | 4560 | RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos); |
d06b3496 JD |
4561 | RETM m = match_vtag (&tag_pending, &inquire->pending); |
4562 | RETM m = match_vtag (&tag_id, &inquire->id); | |
93e8af19 | 4563 | RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream); |
0ef33d44 FR |
4564 | RETM m = match_dec_vtag (&tag_v_share, &inquire->share); |
4565 | RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc); | |
6de9cd9a DN |
4566 | RETM return MATCH_NO; |
4567 | } | |
4568 | ||
4569 | #undef RETM | |
4570 | ||
4571 | ||
4572 | match | |
4573 | gfc_match_inquire (void) | |
4574 | { | |
4575 | gfc_inquire *inquire; | |
4576 | gfc_code *code; | |
4577 | match m; | |
44998b65 | 4578 | locus loc; |
6de9cd9a DN |
4579 | |
4580 | m = gfc_match_char ('('); | |
4581 | if (m == MATCH_NO) | |
4582 | return m; | |
4583 | ||
ece3f663 | 4584 | inquire = XCNEW (gfc_inquire); |
6de9cd9a | 4585 | |
44998b65 JB |
4586 | loc = gfc_current_locus; |
4587 | ||
6de9cd9a DN |
4588 | m = match_inquire_element (inquire); |
4589 | if (m == MATCH_ERROR) | |
4590 | goto cleanup; | |
4591 | if (m == MATCH_NO) | |
4592 | { | |
4593 | m = gfc_match_expr (&inquire->unit); | |
4594 | if (m == MATCH_ERROR) | |
4595 | goto cleanup; | |
4596 | if (m == MATCH_NO) | |
4597 | goto syntax; | |
4598 | } | |
4599 | ||
4600 | /* See if we have the IOLENGTH form of the inquire statement. */ | |
4601 | if (inquire->iolength != NULL) | |
4602 | { | |
4603 | if (gfc_match_char (')') != MATCH_YES) | |
4604 | goto syntax; | |
4605 | ||
4606 | m = match_io_list (M_INQUIRE, &code); | |
4607 | if (m == MATCH_ERROR) | |
4608 | goto cleanup; | |
4609 | if (m == MATCH_NO) | |
4610 | goto syntax; | |
4611 | ||
84e33251 SK |
4612 | for (gfc_code *c = code; c; c = c->next) |
4613 | if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION | |
4614 | && c->expr1->symtree && c->expr1->symtree->n.sym->attr.function | |
4615 | && !c->expr1->symtree->n.sym->attr.external | |
4616 | && strcmp (c->expr1->symtree->name, "null") == 0) | |
4617 | { | |
4618 | gfc_error ("NULL() near %L cannot appear in INQUIRE statement", | |
4619 | &c->expr1->where); | |
4620 | goto cleanup; | |
4621 | } | |
4622 | ||
6de9cd9a | 4623 | new_st.op = EXEC_IOLENGTH; |
a513927a | 4624 | new_st.expr1 = inquire->iolength; |
8750f9cd | 4625 | new_st.ext.inquire = inquire; |
6de9cd9a DN |
4626 | |
4627 | if (gfc_pure (NULL)) | |
4628 | { | |
4629 | gfc_free_statements (code); | |
4630 | gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); | |
4631 | return MATCH_ERROR; | |
4632 | } | |
4633 | ||
ccd7751b | 4634 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 4635 | |
11e5274a | 4636 | new_st.block = gfc_get_code (EXEC_IOLENGTH); |
5e805e44 JJ |
4637 | terminate_io (code); |
4638 | new_st.block->next = code; | |
6de9cd9a DN |
4639 | return MATCH_YES; |
4640 | } | |
4641 | ||
4642 | /* At this point, we have the non-IOLENGTH inquire statement. */ | |
4643 | for (;;) | |
4644 | { | |
4645 | if (gfc_match_char (')') == MATCH_YES) | |
4646 | break; | |
4647 | if (gfc_match_char (',') != MATCH_YES) | |
4648 | goto syntax; | |
4649 | ||
4650 | m = match_inquire_element (inquire); | |
4651 | if (m == MATCH_ERROR) | |
4652 | goto cleanup; | |
4653 | if (m == MATCH_NO) | |
4654 | goto syntax; | |
4655 | ||
4656 | if (inquire->iolength != NULL) | |
4657 | { | |
4658 | gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C"); | |
4659 | goto cleanup; | |
4660 | } | |
4661 | } | |
4662 | ||
4663 | if (gfc_match_eos () != MATCH_YES) | |
4664 | goto syntax; | |
4665 | ||
44998b65 JB |
4666 | if (inquire->unit != NULL && inquire->file != NULL) |
4667 | { | |
b251af97 SK |
4668 | gfc_error ("INQUIRE statement at %L cannot contain both FILE and " |
4669 | "UNIT specifiers", &loc); | |
44998b65 JB |
4670 | goto cleanup; |
4671 | } | |
4672 | ||
4673 | if (inquire->unit == NULL && inquire->file == NULL) | |
4674 | { | |
b251af97 SK |
4675 | gfc_error ("INQUIRE statement at %L requires either FILE or " |
4676 | "UNIT specifier", &loc); | |
44998b65 JB |
4677 | goto cleanup; |
4678 | } | |
4679 | ||
2da229cb JD |
4680 | if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT |
4681 | && inquire->unit->ts.type == BT_INTEGER | |
4a8d4422 JD |
4682 | && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4) |
4683 | || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT))) | |
2da229cb | 4684 | { |
67914693 | 4685 | gfc_error ("UNIT number in INQUIRE statement at %L cannot " |
4a8d4422 | 4686 | "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer)); |
2da229cb JD |
4687 | goto cleanup; |
4688 | } | |
4689 | ||
6de9cd9a DN |
4690 | if (gfc_pure (NULL)) |
4691 | { | |
4692 | gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); | |
4693 | goto cleanup; | |
4694 | } | |
f1f39033 | 4695 | |
ccd7751b | 4696 | gfc_unset_implicit_pure (NULL); |
d06b3496 JD |
4697 | |
4698 | if (inquire->id != NULL && inquire->pending == NULL) | |
4699 | { | |
4700 | gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with " | |
4701 | "the ID= specifier", &loc); | |
4702 | goto cleanup; | |
4703 | } | |
6de9cd9a DN |
4704 | |
4705 | new_st.op = EXEC_INQUIRE; | |
4706 | new_st.ext.inquire = inquire; | |
4707 | return MATCH_YES; | |
4708 | ||
4709 | syntax: | |
4710 | gfc_syntax_error (ST_INQUIRE); | |
4711 | ||
4712 | cleanup: | |
4713 | gfc_free_inquire (inquire); | |
4714 | return MATCH_ERROR; | |
4715 | } | |
4716 | ||
4717 | ||
4718 | /* Resolve everything in a gfc_inquire structure. */ | |
4719 | ||
524af0d6 | 4720 | bool |
b251af97 | 4721 | gfc_resolve_inquire (gfc_inquire *inquire) |
6de9cd9a | 4722 | { |
6de9cd9a DN |
4723 | RESOLVE_TAG (&tag_unit, inquire->unit); |
4724 | RESOLVE_TAG (&tag_file, inquire->file); | |
d06b3496 | 4725 | RESOLVE_TAG (&tag_id, inquire->id); |
6de9cd9a | 4726 | |
8e8dc060 DK |
4727 | /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition |
4728 | contexts. Thus, use an extended RESOLVE_TAG macro for that. */ | |
4729 | #define INQUIRE_RESOLVE_TAG(tag, expr) \ | |
4730 | RESOLVE_TAG (tag, expr); \ | |
4731 | if (expr) \ | |
4732 | { \ | |
4733 | char context[64]; \ | |
4734 | sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \ | |
57bf28ea | 4735 | if (gfc_check_vardef_context ((expr), false, false, false, \ |
524af0d6 JB |
4736 | context) == false) \ |
4737 | return false; \ | |
8e8dc060 DK |
4738 | } |
4739 | INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg); | |
4740 | INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat); | |
4741 | INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist); | |
4742 | INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened); | |
4743 | INQUIRE_RESOLVE_TAG (&tag_number, inquire->number); | |
4744 | INQUIRE_RESOLVE_TAG (&tag_named, inquire->named); | |
4745 | INQUIRE_RESOLVE_TAG (&tag_name, inquire->name); | |
4746 | INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access); | |
4747 | INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential); | |
4748 | INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct); | |
4749 | INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form); | |
4750 | INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted); | |
4751 | INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted); | |
4752 | INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl); | |
4753 | INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec); | |
4754 | INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank); | |
4755 | INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position); | |
4756 | INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action); | |
4757 | INQUIRE_RESOLVE_TAG (&tag_read, inquire->read); | |
4758 | INQUIRE_RESOLVE_TAG (&tag_write, inquire->write); | |
4759 | INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite); | |
4760 | INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim); | |
4761 | INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad); | |
4762 | INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding); | |
4763 | INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); | |
4764 | INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength); | |
4765 | INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert); | |
4766 | INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); | |
4767 | INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous); | |
4768 | INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign); | |
4769 | INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); | |
4770 | INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending); | |
4771 | INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); | |
75933b07 | 4772 | INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal); |
93e8af19 | 4773 | INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream); |
0ef33d44 FR |
4774 | INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share); |
4775 | INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc); | |
8e8dc060 DK |
4776 | #undef INQUIRE_RESOLVE_TAG |
4777 | ||
524af0d6 JB |
4778 | if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET)) |
4779 | return false; | |
6de9cd9a | 4780 | |
524af0d6 | 4781 | return true; |
6de9cd9a | 4782 | } |
6f0f0b2e JD |
4783 | |
4784 | ||
4785 | void | |
4786 | gfc_free_wait (gfc_wait *wait) | |
4787 | { | |
4788 | if (wait == NULL) | |
4789 | return; | |
4790 | ||
4791 | gfc_free_expr (wait->unit); | |
4792 | gfc_free_expr (wait->iostat); | |
4793 | gfc_free_expr (wait->iomsg); | |
4794 | gfc_free_expr (wait->id); | |
efb63364 | 4795 | free (wait); |
6f0f0b2e JD |
4796 | } |
4797 | ||
4798 | ||
524af0d6 | 4799 | bool |
6f0f0b2e JD |
4800 | gfc_resolve_wait (gfc_wait *wait) |
4801 | { | |
4802 | RESOLVE_TAG (&tag_unit, wait->unit); | |
4803 | RESOLVE_TAG (&tag_iomsg, wait->iomsg); | |
4804 | RESOLVE_TAG (&tag_iostat, wait->iostat); | |
4805 | RESOLVE_TAG (&tag_id, wait->id); | |
4806 | ||
524af0d6 JB |
4807 | if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET)) |
4808 | return false; | |
6f0f0b2e | 4809 | |
524af0d6 JB |
4810 | if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET)) |
4811 | return false; | |
6f0f0b2e | 4812 | |
524af0d6 | 4813 | return true; |
6f0f0b2e JD |
4814 | } |
4815 | ||
4816 | /* Match an element of a WAIT statement. */ | |
4817 | ||
4818 | #define RETM if (m != MATCH_NO) return m; | |
4819 | ||
4820 | static match | |
4821 | match_wait_element (gfc_wait *wait) | |
4822 | { | |
4823 | match m; | |
4824 | ||
4825 | m = match_etag (&tag_unit, &wait->unit); | |
4826 | RETM m = match_ltag (&tag_err, &wait->err); | |
4f8d1d32 TK |
4827 | RETM m = match_ltag (&tag_end, &wait->end); |
4828 | RETM m = match_ltag (&tag_eor, &wait->eor); | |
fd5cabb2 | 4829 | RETM m = match_etag (&tag_iomsg, &wait->iomsg); |
6f0f0b2e JD |
4830 | RETM m = match_out_tag (&tag_iostat, &wait->iostat); |
4831 | RETM m = match_etag (&tag_id, &wait->id); | |
4832 | RETM return MATCH_NO; | |
4833 | } | |
4834 | ||
4835 | #undef RETM | |
4836 | ||
4837 | ||
4838 | match | |
4839 | gfc_match_wait (void) | |
4840 | { | |
4841 | gfc_wait *wait; | |
4842 | match m; | |
6f0f0b2e JD |
4843 | |
4844 | m = gfc_match_char ('('); | |
4845 | if (m == MATCH_NO) | |
4846 | return m; | |
4847 | ||
ece3f663 | 4848 | wait = XCNEW (gfc_wait); |
6f0f0b2e | 4849 | |
6f0f0b2e JD |
4850 | m = match_wait_element (wait); |
4851 | if (m == MATCH_ERROR) | |
4852 | goto cleanup; | |
4853 | if (m == MATCH_NO) | |
4854 | { | |
4855 | m = gfc_match_expr (&wait->unit); | |
4856 | if (m == MATCH_ERROR) | |
4857 | goto cleanup; | |
4858 | if (m == MATCH_NO) | |
4859 | goto syntax; | |
4860 | } | |
4861 | ||
4862 | for (;;) | |
4863 | { | |
4864 | if (gfc_match_char (')') == MATCH_YES) | |
4865 | break; | |
4866 | if (gfc_match_char (',') != MATCH_YES) | |
4867 | goto syntax; | |
4868 | ||
4869 | m = match_wait_element (wait); | |
4870 | if (m == MATCH_ERROR) | |
4871 | goto cleanup; | |
4872 | if (m == MATCH_NO) | |
4873 | goto syntax; | |
4874 | } | |
4875 | ||
524af0d6 JB |
4876 | if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C " |
4877 | "not allowed in Fortran 95")) | |
6f0f0b2e JD |
4878 | goto cleanup; |
4879 | ||
4880 | if (gfc_pure (NULL)) | |
4881 | { | |
4882 | gfc_error ("WAIT statement not allowed in PURE procedure at %C"); | |
4883 | goto cleanup; | |
4884 | } | |
4885 | ||
ccd7751b | 4886 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 4887 | |
6f0f0b2e JD |
4888 | new_st.op = EXEC_WAIT; |
4889 | new_st.ext.wait = wait; | |
4890 | ||
4891 | return MATCH_YES; | |
4892 | ||
4893 | syntax: | |
4894 | gfc_syntax_error (ST_WAIT); | |
4895 | ||
4896 | cleanup: | |
4897 | gfc_free_wait (wait); | |
4898 | return MATCH_ERROR; | |
4899 | } |