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