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