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