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 165804 : next_char (gfc_instring in_string)
148 : {
149 165804 : static gfc_char_t c;
150 :
151 165804 : if (use_last_char)
152 : {
153 28421 : use_last_char = 0;
154 28421 : return c;
155 : }
156 :
157 137383 : format_length++;
158 :
159 137383 : if (mode == MODE_STRING)
160 79965 : c = *format_string++;
161 : else
162 : {
163 57418 : c = gfc_next_char_literal (in_string);
164 57418 : if (c == '\n')
165 0 : c = '\0';
166 : }
167 :
168 137383 : 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 137383 : if (mode == MODE_COPY)
180 28649 : *format_string++ = c;
181 :
182 137383 : if (mode != MODE_STRING)
183 57418 : format_locus = gfc_current_locus;
184 :
185 137383 : format_string_pos++;
186 :
187 137383 : c = gfc_wide_toupper (c);
188 137383 : return c;
189 : }
190 :
191 :
192 : /* Back up one character position. Only works once. */
193 :
194 : static void
195 28427 : unget_char (void)
196 : {
197 28427 : use_last_char = 1;
198 2616 : }
199 :
200 : /* Eat up the spaces and return a character. */
201 :
202 : static char
203 126657 : next_char_not_space ()
204 : {
205 135212 : char c;
206 135212 : do
207 : {
208 135212 : error_element = c = next_char (NONSTRING);
209 135212 : if (c == '\t')
210 4 : gfc_warning (OPT_Wtabs, "Nonconforming tab character in format at %C");
211 : }
212 135212 : while (gfc_is_whitespace (c));
213 126657 : 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 121321 : format_lex (void)
223 : {
224 121321 : format_token token;
225 121321 : char c, delim;
226 121321 : int zflag;
227 121321 : int negative_flag;
228 :
229 121321 : if (saved_token != FMT_NONE)
230 : {
231 27748 : token = saved_token;
232 27748 : saved_token = FMT_NONE;
233 27748 : return token;
234 : }
235 :
236 93573 : c = next_char_not_space ();
237 :
238 93573 : negative_flag = 0;
239 93573 : 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 23403 : case '0':
272 23403 : case '1':
273 23403 : case '2':
274 23403 : case '3':
275 23403 : case '4':
276 23403 : case '5':
277 23403 : case '6':
278 23403 : case '7':
279 23403 : case '8':
280 23403 : case '9':
281 23403 : zflag = (c == '0');
282 :
283 23403 : value = c - '0';
284 :
285 28333 : do
286 : {
287 28333 : c = next_char_not_space ();
288 28333 : if (ISDIGIT (c))
289 : {
290 4930 : value = 10 * value + (c - '0');
291 4930 : if (c != '0')
292 28333 : zflag = 0;
293 : }
294 : }
295 28333 : while (ISDIGIT (c));
296 :
297 23403 : unget_char ();
298 23403 : token = zflag ? FMT_ZERO : FMT_POSINT;
299 : break;
300 :
301 : case '.':
302 : token = FMT_PERIOD;
303 : break;
304 :
305 10886 : case ',':
306 10886 : token = FMT_COMMA;
307 10886 : 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 962 : case 'T':
322 962 : c = next_char_not_space ();
323 962 : switch (c)
324 : {
325 : case 'L':
326 : token = FMT_TL;
327 : break;
328 168 : case 'R':
329 168 : token = FMT_TR;
330 168 : break;
331 605 : default:
332 605 : token = FMT_T;
333 605 : unget_char ();
334 : }
335 : break;
336 :
337 14347 : case '(':
338 14347 : token = FMT_LPAREN;
339 14347 : break;
340 :
341 14317 : case ')':
342 14317 : token = FMT_RPAREN;
343 14317 : 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 2276 : case '\'':
370 2276 : case '"':
371 2276 : delim = c;
372 :
373 2276 : value = 0;
374 :
375 50546 : for (;;)
376 : {
377 26411 : c = next_char (INSTRING_WARN);
378 26411 : if (c == '\0')
379 : {
380 : token = FMT_END;
381 : break;
382 : }
383 :
384 26411 : if (c == delim)
385 : {
386 2450 : c = next_char (NONSTRING);
387 :
388 2450 : if (c == '\0')
389 : {
390 : token = FMT_END;
391 : break;
392 : }
393 :
394 2450 : if (c != delim)
395 : {
396 2276 : unget_char ();
397 2276 : token = FMT_CHAR;
398 2276 : break;
399 : }
400 : }
401 24135 : 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 4791 : 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 7911 : case 'A':
479 7911 : token = FMT_A;
480 7911 : 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 128 : case '*':
588 128 : token = FMT_STAR;
589 128 : 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 13255 : check_format (bool is_input)
627 : {
628 13255 : const char *posint_required
629 : = G_("Positive width required in format string at %L");
630 13255 : const char *nonneg_required
631 : = G_("Nonnegative width required in format string at %L");
632 13255 : const char *unexpected_element
633 : = G_("Unexpected element %qc in format string at %L");
634 13255 : const char *unexpected_end
635 : = G_("Unexpected end of format string in format string at %L");
636 13255 : const char *zero_width
637 : = G_("Zero width in format descriptor in format string at %L");
638 :
639 13255 : const char *error = NULL;
640 13255 : format_token t, u;
641 13255 : int level;
642 13255 : int repeat;
643 13255 : bool rv;
644 :
645 13255 : use_last_char = 0;
646 13255 : saved_token = FMT_NONE;
647 13255 : level = 0;
648 13255 : repeat = 0;
649 13255 : rv = true;
650 13255 : format_string_pos = 0;
651 :
652 13255 : t = format_lex ();
653 13255 : if (t == FMT_ERROR)
654 0 : goto fail;
655 13255 : 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 13249 : t = format_lex ();
662 13249 : if (t == FMT_ERROR)
663 0 : goto fail;
664 13249 : if (t == FMT_RPAREN)
665 52 : goto finished; /* Empty format is legal */
666 13197 : saved_token = t;
667 :
668 25982 : format_item:
669 : /* In this state, the next thing has to be a format item. */
670 25982 : t = format_lex ();
671 25982 : if (t == FMT_ERROR)
672 0 : goto fail;
673 25982 : format_item_1:
674 26023 : switch (t)
675 : {
676 128 : case FMT_STAR:
677 128 : repeat = -1;
678 128 : t = format_lex ();
679 128 : if (t == FMT_ERROR)
680 0 : goto fail;
681 128 : if (t == FMT_LPAREN)
682 : {
683 128 : level++;
684 128 : goto format_item;
685 : }
686 0 : error = G_("Left parenthesis required after %<*%> in format string "
687 : "at %L");
688 0 : goto syntax;
689 :
690 5920 : case FMT_POSINT:
691 5920 : repeat = value;
692 5920 : t = format_lex ();
693 5920 : if (t == FMT_ERROR)
694 0 : goto fail;
695 5920 : if (t == FMT_LPAREN)
696 : {
697 782 : level++;
698 782 : 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 2276 : case FMT_CHAR:
752 2276 : 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 16276 : case FMT_T:
775 16276 : case FMT_TL:
776 16276 : case FMT_TR:
777 16276 : case FMT_IBOZ:
778 16276 : case FMT_F:
779 16276 : case FMT_E:
780 16276 : case FMT_EN:
781 16276 : case FMT_ES:
782 16276 : case FMT_EX:
783 16276 : case FMT_G:
784 16276 : case FMT_L:
785 16276 : case FMT_A:
786 16276 : case FMT_D:
787 16276 : case FMT_H:
788 16276 : case FMT_DT:
789 16276 : 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 21437 : data_desc:
810 : /* In this state, t must currently be a data descriptor.
811 : Deal with things that can/must follow the descriptor. */
812 21437 : 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 961 : case FMT_T:
856 961 : case FMT_TL:
857 961 : case FMT_TR:
858 961 : t = format_lex ();
859 961 : 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 7905 : case FMT_A:
902 7905 : t = format_lex ();
903 7905 : if (t == FMT_ERROR)
904 0 : goto fail;
905 7905 : if (t == FMT_ZERO)
906 : {
907 0 : error = zero_width;
908 0 : goto syntax;
909 : }
910 7905 : if (t != FMT_POSINT)
911 6332 : 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 4791 : case FMT_IBOZ:
1194 4791 : t = format_lex ();
1195 4791 : if (t == FMT_ERROR)
1196 0 : goto fail;
1197 4791 : 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 4724 : else if (is_input && t == FMT_ZERO)
1212 : {
1213 2 : error = posint_required;
1214 2 : goto syntax;
1215 : }
1216 :
1217 4782 : t = format_lex ();
1218 4782 : if (t == FMT_ERROR)
1219 0 : goto fail;
1220 4782 : if (t != FMT_PERIOD)
1221 4338 : 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 22233 : t = format_lex ();
1244 22233 : if (t == FMT_ERROR)
1245 0 : goto fail;
1246 22233 : switch (t)
1247 : {
1248 :
1249 9260 : case FMT_COMMA:
1250 9260 : goto format_item;
1251 :
1252 12686 : case FMT_RPAREN:
1253 12686 : level--;
1254 12686 : if (level < 0)
1255 11878 : 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 2276 : extension_optional_comma:
1306 : /* As a GNU extension, permit a missing comma after a string literal. */
1307 2276 : t = format_lex ();
1308 2276 : if (t == FMT_ERROR)
1309 0 : goto fail;
1310 2276 : switch (t)
1311 : {
1312 : case FMT_COMMA:
1313 : break;
1314 :
1315 1056 : case FMT_RPAREN:
1316 1056 : level--;
1317 1056 : if (level < 0)
1318 930 : goto finished;
1319 126 : 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 1177 : 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 12287 : check_format_string (gfc_expr *e, bool is_input)
1365 : {
1366 12287 : bool rv;
1367 12287 : int i;
1368 12287 : if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1369 : return true;
1370 :
1371 11216 : mode = MODE_STRING;
1372 11216 : 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 11216 : format_locus = e->where;
1378 11216 : 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 11216 : 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 1024 : gfc_match_format (void)
1404 : {
1405 1024 : gfc_expr *e;
1406 1024 : locus start;
1407 :
1408 1024 : if (gfc_current_ns->proc_name
1409 997 : && 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 1023 : if ((gfc_current_state () == COMP_FUNCTION
1417 1023 : || gfc_current_state () == COMP_SUBROUTINE)
1418 171 : && 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 1022 : if (gfc_statement_label == NULL)
1425 : {
1426 0 : gfc_error ("Missing format label at %C");
1427 0 : return MATCH_ERROR;
1428 : }
1429 1022 : gfc_gobble_whitespace ();
1430 :
1431 1022 : mode = MODE_FORMAT;
1432 1022 : format_length = 0;
1433 :
1434 1022 : start = gfc_current_locus;
1435 :
1436 1022 : if (!check_format (false))
1437 : return MATCH_ERROR;
1438 :
1439 1017 : 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 1017 : gfc_current_locus = start; /* Back to the beginning */
1449 :
1450 1017 : new_st.loc = start;
1451 1017 : new_st.op = EXEC_NOP;
1452 :
1453 1017 : e = gfc_get_character_expr (gfc_default_character_kind, &start,
1454 : NULL, format_length);
1455 1017 : format_string = e->value.character.string;
1456 1017 : gfc_statement_label->format = e;
1457 :
1458 1017 : mode = MODE_COPY;
1459 1017 : check_format (false); /* Guaranteed to succeed */
1460 1017 : gfc_match_eos (); /* Guaranteed to succeed */
1461 :
1462 1017 : return MATCH_YES;
1463 : }
1464 :
1465 :
1466 : /* Match an expression I/O tag of some sort. */
1467 :
1468 : static match
1469 671617 : match_etag (const io_tag *tag, gfc_expr **v)
1470 : {
1471 671617 : gfc_expr *result;
1472 671617 : match m;
1473 :
1474 671617 : m = gfc_match (tag->spec);
1475 671617 : if (m != MATCH_YES)
1476 : return m;
1477 :
1478 12791 : m = gfc_match (tag->value, &result);
1479 12791 : 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 12791 : 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 12789 : *v = result;
1493 12789 : return MATCH_YES;
1494 : }
1495 :
1496 :
1497 : /* Match a variable I/O tag of some sort. */
1498 :
1499 : static match
1500 196569 : match_vtag (const io_tag *tag, gfc_expr **v)
1501 : {
1502 196569 : gfc_expr *result;
1503 196569 : match m;
1504 :
1505 196569 : m = gfc_match (tag->spec);
1506 196569 : if (m != MATCH_YES)
1507 : return m;
1508 :
1509 4045 : m = gfc_match (tag->value, &result);
1510 4045 : 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 4044 : 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 4044 : if (result->symtree)
1524 : {
1525 4040 : bool impure;
1526 :
1527 4040 : 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 4040 : impure = gfc_impure_variable (result->symtree->n.sym);
1535 4040 : 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 4040 : if (impure)
1544 28 : gfc_unset_implicit_pure (NULL);
1545 : }
1546 :
1547 4044 : *v = result;
1548 4044 : return MATCH_YES;
1549 : }
1550 :
1551 :
1552 : /* Match I/O tags that cause variables to become redefined. */
1553 :
1554 : static match
1555 168786 : match_out_tag (const io_tag *tag, gfc_expr **result)
1556 : {
1557 168786 : match m;
1558 :
1559 168786 : m = match_vtag (tag, result);
1560 168786 : if (m == MATCH_YES)
1561 : {
1562 2827 : if ((*result)->symtree)
1563 2823 : gfc_check_do_variable ((*result)->symtree);
1564 :
1565 2827 : 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 147256 : match_ltag (const io_tag *tag, gfc_st_label ** label)
1580 : {
1581 147256 : match m;
1582 147256 : gfc_st_label *old;
1583 :
1584 147256 : old = *label;
1585 147256 : m = gfc_match (tag->spec);
1586 147256 : 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 5832 : match_dec_etag (const io_tag *tag, gfc_expr **e)
1612 : {
1613 5832 : match m = match_etag (tag, e);
1614 5832 : if (flag_dec && m != MATCH_NO)
1615 : return m;
1616 5669 : 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 8569 : match_dec_ftag (const io_tag *tag, gfc_open *o)
1647 : {
1648 8569 : match m;
1649 :
1650 8569 : m = gfc_match (tag->spec);
1651 8569 : 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 12248 : resolve_tag_format (gfc_expr *e)
1704 : {
1705 12248 : if (e->expr_type == EXPR_CONSTANT
1706 11185 : && (e->ts.type != BT_CHARACTER
1707 11181 : || 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 12222 : if ((e->expr_type == EXPR_ARRAY || e->rank > 0)
1718 111 : && e->ts.type == BT_CHARACTER
1719 12317 : && 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 12242 : if (e->rank == 0
1766 12133 : && (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 12054 : if ((e->ts.type != BT_CHARACTER
1772 12045 : || 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 12049 : 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 12046 : 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 12045 : gfc_value_used_expr (e, VALUE_USED);
1799 12045 : 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 639056 : resolve_tag (const io_tag *tag, gfc_expr *e)
1848 : {
1849 639056 : if (e == NULL)
1850 : return true;
1851 :
1852 37807 : if (!gfc_resolve_expr (e))
1853 : return false;
1854 :
1855 37803 : if (tag == &tag_format)
1856 12248 : return resolve_tag_format (e);
1857 :
1858 25555 : 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 25207 : 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 25139 : 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 25087 : 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 25087 : if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength
1885 22756 : || 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 25071 : if (e->ts.kind != gfc_default_logical_kind &&
1894 10981 : (tag == &tag_exist || tag == &tag_named || tag == &tag_opened
1895 10975 : || 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 25063 : if (tag == &tag_newunit)
1903 : {
1904 146 : if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L",
1905 : &e->where))
1906 : return false;
1907 : }
1908 :
1909 25062 : 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 25062 : if (tag == &tag_newunit || tag == &tag_iostat
1917 22793 : || tag == &tag_size || tag == &tag_iomsg)
1918 : {
1919 2939 : char context[64];
1920 :
1921 2939 : sprintf (context, _("%s tag"), tag->name);
1922 2939 : if (!gfc_check_vardef_context (e, false, false, false, context))
1923 32 : return false;
1924 :
1925 2907 : gfc_expr_set_at (e, &e->where, VALUE_VARDEF);
1926 2907 : }
1927 : else
1928 22123 : 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 11144 : match_open_element (gfc_open *open)
1938 : {
1939 11144 : match m;
1940 :
1941 11144 : m = match_etag (&tag_e_async, &open->asynchronous);
1942 11144 : if (m != MATCH_NO)
1943 : return m;
1944 11028 : m = match_etag (&tag_unit, &open->unit);
1945 11028 : if (m != MATCH_NO)
1946 : return m;
1947 10086 : m = match_etag (&tag_iomsg, &open->iomsg);
1948 10086 : if (m != MATCH_NO)
1949 : return m;
1950 10028 : m = match_out_tag (&tag_iostat, &open->iostat);
1951 10028 : if (m != MATCH_NO)
1952 : return m;
1953 9853 : m = match_etag (&tag_file, &open->file);
1954 9853 : if (m != MATCH_NO)
1955 : return m;
1956 8347 : m = match_etag (&tag_status, &open->status);
1957 8347 : if (m != MATCH_NO)
1958 : return m;
1959 6201 : m = match_etag (&tag_e_access, &open->access);
1960 6201 : if (m != MATCH_NO)
1961 : return m;
1962 5420 : m = match_etag (&tag_e_form, &open->form);
1963 5420 : if (m != MATCH_NO)
1964 : return m;
1965 4321 : m = match_etag (&tag_e_recl, &open->recl);
1966 4321 : if (m != MATCH_NO)
1967 : return m;
1968 4067 : m = match_etag (&tag_e_blank, &open->blank);
1969 4067 : if (m != MATCH_NO)
1970 : return m;
1971 4028 : m = match_etag (&tag_e_position, &open->position);
1972 4028 : if (m != MATCH_NO)
1973 : return m;
1974 3892 : m = match_etag (&tag_e_action, &open->action);
1975 3892 : if (m != MATCH_NO)
1976 : return m;
1977 3630 : m = match_etag (&tag_e_delim, &open->delim);
1978 3630 : if (m != MATCH_NO)
1979 : return m;
1980 3487 : m = match_etag (&tag_e_pad, &open->pad);
1981 3487 : if (m != MATCH_NO)
1982 : return m;
1983 3432 : m = match_etag (&tag_e_decimal, &open->decimal);
1984 3432 : if (m != MATCH_NO)
1985 : return m;
1986 3382 : m = match_etag (&tag_e_encoding, &open->encoding);
1987 3382 : if (m != MATCH_NO)
1988 : return m;
1989 3308 : m = match_etag (&tag_e_round, &open->round);
1990 3308 : if (m != MATCH_NO)
1991 : return m;
1992 3294 : m = match_etag (&tag_e_sign, &open->sign);
1993 3294 : if (m != MATCH_NO)
1994 : return m;
1995 3262 : m = match_ltag (&tag_err, &open->err);
1996 3262 : if (m != MATCH_NO)
1997 : return m;
1998 3146 : m = match_etag (&tag_convert, &open->convert);
1999 3146 : if (m != MATCH_NO)
2000 : return m;
2001 3074 : m = match_out_tag (&tag_newunit, &open->newunit);
2002 3074 : if (m != MATCH_NO)
2003 : return m;
2004 :
2005 : /* The following are extensions enabled with -fdec. */
2006 2925 : m = match_dec_etag (&tag_e_share, &open->share);
2007 2925 : if (m != MATCH_NO)
2008 : return m;
2009 2907 : m = match_dec_etag (&tag_cc, &open->cc);
2010 2907 : if (m != MATCH_NO)
2011 : return m;
2012 2876 : m = match_dec_ftag (&tag_readonly, open);
2013 2876 : if (m != MATCH_NO)
2014 : return m;
2015 2852 : m = match_dec_ftag (&tag_shared, open);
2016 2852 : if (m != MATCH_NO)
2017 : return m;
2018 2841 : m = match_dec_ftag (&tag_noshared, open);
2019 2841 : 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 3924 : gfc_free_open (gfc_open *open)
2030 : {
2031 3924 : if (open == NULL)
2032 : return;
2033 :
2034 3924 : gfc_free_expr (open->unit);
2035 3924 : gfc_free_expr (open->iomsg);
2036 3924 : gfc_free_expr (open->iostat);
2037 3924 : gfc_free_expr (open->file);
2038 3924 : gfc_free_expr (open->status);
2039 3924 : gfc_free_expr (open->access);
2040 3924 : gfc_free_expr (open->form);
2041 3924 : gfc_free_expr (open->recl);
2042 3924 : gfc_free_expr (open->blank);
2043 3924 : gfc_free_expr (open->position);
2044 3924 : gfc_free_expr (open->action);
2045 3924 : gfc_free_expr (open->delim);
2046 3924 : gfc_free_expr (open->pad);
2047 3924 : gfc_free_expr (open->decimal);
2048 3924 : gfc_free_expr (open->encoding);
2049 3924 : gfc_free_expr (open->round);
2050 3924 : gfc_free_expr (open->sign);
2051 3924 : gfc_free_expr (open->convert);
2052 3924 : gfc_free_expr (open->asynchronous);
2053 3924 : gfc_free_expr (open->newunit);
2054 3924 : gfc_free_expr (open->share);
2055 3924 : gfc_free_expr (open->cc);
2056 3924 : 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 3907 : gfc_resolve_open (gfc_open *open, locus *where)
2066 : {
2067 3907 : RESOLVE_TAG (&tag_unit, open->unit);
2068 3907 : RESOLVE_TAG (&tag_iomsg, open->iomsg);
2069 3891 : RESOLVE_TAG (&tag_iostat, open->iostat);
2070 3890 : RESOLVE_TAG (&tag_file, open->file);
2071 3889 : RESOLVE_TAG (&tag_status, open->status);
2072 3875 : RESOLVE_TAG (&tag_e_access, open->access);
2073 3863 : RESOLVE_TAG (&tag_e_form, open->form);
2074 3852 : RESOLVE_TAG (&tag_e_recl, open->recl);
2075 3846 : RESOLVE_TAG (&tag_e_blank, open->blank);
2076 3834 : RESOLVE_TAG (&tag_e_position, open->position);
2077 3823 : RESOLVE_TAG (&tag_e_action, open->action);
2078 3812 : RESOLVE_TAG (&tag_e_delim, open->delim);
2079 3801 : RESOLVE_TAG (&tag_e_pad, open->pad);
2080 3790 : RESOLVE_TAG (&tag_e_decimal, open->decimal);
2081 3778 : RESOLVE_TAG (&tag_e_encoding, open->encoding);
2082 3766 : RESOLVE_TAG (&tag_e_async, open->asynchronous);
2083 3755 : RESOLVE_TAG (&tag_e_round, open->round);
2084 3743 : RESOLVE_TAG (&tag_e_sign, open->sign);
2085 3731 : RESOLVE_TAG (&tag_convert, open->convert);
2086 3731 : RESOLVE_TAG (&tag_newunit, open->newunit);
2087 3729 : RESOLVE_TAG (&tag_e_share, open->share);
2088 3728 : RESOLVE_TAG (&tag_cc, open->cc);
2089 :
2090 3727 : if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
2091 : return false;
2092 :
2093 3727 : 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 6943 : 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 6943 : int i;
2110 6943 : unsigned int len;
2111 :
2112 6943 : len = gfc_wide_strlen (value);
2113 6943 : if (len > 0)
2114 : {
2115 6930 : for (len--; len > 0; len--)
2116 6930 : if (value[len] != ' ')
2117 : break;
2118 6912 : len++;
2119 : }
2120 :
2121 15548 : for (i = 0; allowed[i]; i++)
2122 15015 : if (len == strlen (allowed[i])
2123 15015 : && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
2124 : {
2125 6410 : if (num)
2126 199 : *num = i;
2127 6410 : return 1;
2128 : }
2129 :
2130 533 : if (!where)
2131 0 : where = &gfc_current_locus;
2132 :
2133 562 : for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
2134 443 : if (len == strlen (allowed_f2003[i])
2135 443 : && gfc_wide_strncasecmp (value, allowed_f2003[i],
2136 : strlen (allowed_f2003[i])) == 0)
2137 : {
2138 414 : notification n = gfc_notification_std (GFC_STD_F2003);
2139 :
2140 414 : 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 414 : 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 3727 : 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 3727 : bool warn = (open->err || open->iostat) ? true : false;
2227 :
2228 : /* Checks on the ACCESS specifier. */
2229 3727 : if (open->access && open->access->expr_type == EXPR_CONSTANT)
2230 : {
2231 769 : static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
2232 769 : static const char *access_f2003[] = { "STREAM", NULL };
2233 769 : static const char *access_gnu[] = { "APPEND", NULL };
2234 :
2235 769 : 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 3723 : 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 3485 : 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 3718 : 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 3717 : 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 3714 : 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 3714 : 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 3712 : if (open->delim)
2332 : {
2333 132 : if (open->delim->expr_type == EXPR_CONSTANT)
2334 : {
2335 132 : static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
2336 :
2337 132 : 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 3709 : 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 3707 : if (open->form && open->form->expr_type == EXPR_CONSTANT)
2364 : {
2365 1082 : static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
2366 :
2367 1082 : 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 3704 : 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 3702 : 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 3699 : 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 3697 : 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 3697 : 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 3695 : 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 3693 : if (open->status && open->status->expr_type == EXPR_CONSTANT)
2455 : {
2456 2124 : static const char *status[] = { "OLD", "NEW", "SCRATCH",
2457 : "REPLACE", "UNKNOWN", NULL };
2458 :
2459 2124 : 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 2121 : if (open->file == NULL
2467 2121 : && (gfc_wide_strncasecmp (open->status->value.character.string,
2468 : "replace", 7) == 0
2469 1610 : || 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 2119 : if (gfc_wide_strncasecmp (open->status->value.character.string,
2483 2119 : "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 3687 : if (open->newunit)
2493 : {
2494 144 : 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 144 : if (!open->file &&
2502 27 : (!open->status ||
2503 26 : (open->status->expr_type == EXPR_CONSTANT
2504 25 : && 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 3543 : 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 1085 : if (open->form && open->form->expr_type == EXPR_CONSTANT
2521 1079 : && (open->delim || open->decimal || open->encoding || open->round
2522 1064 : || open->sign || open->pad || open->blank)
2523 3705 : && 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 3905 : && 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 3681 : if (open->position
2562 122 : && open->access && open->access->expr_type == EXPR_CONSTANT
2563 3729 : && !(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 3924 : gfc_match_open (void)
2583 : {
2584 3924 : gfc_open *open;
2585 3924 : match m;
2586 :
2587 3924 : m = gfc_match_char ('(');
2588 3924 : if (m == MATCH_NO)
2589 : return m;
2590 :
2591 3924 : open = XCNEW (gfc_open);
2592 :
2593 3924 : m = match_open_element (open);
2594 :
2595 3924 : if (m == MATCH_ERROR)
2596 0 : goto cleanup;
2597 3924 : if (m == MATCH_NO)
2598 : {
2599 2832 : m = gfc_match_expr (&open->unit);
2600 2832 : if (m == MATCH_ERROR)
2601 0 : goto cleanup;
2602 : }
2603 :
2604 11127 : for (;;)
2605 : {
2606 11127 : if (gfc_match_char (')') == MATCH_YES)
2607 : break;
2608 7220 : if (gfc_match_char (',') != MATCH_YES)
2609 0 : goto syntax;
2610 :
2611 7220 : m = match_open_element (open);
2612 7220 : if (m == MATCH_ERROR)
2613 17 : goto cleanup;
2614 7203 : if (m == MATCH_NO)
2615 0 : goto syntax;
2616 : }
2617 :
2618 3907 : if (gfc_match_eos () == MATCH_NO)
2619 0 : goto syntax;
2620 :
2621 3907 : 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 3907 : gfc_unset_implicit_pure (NULL);
2628 :
2629 3907 : new_st.op = EXEC_OPEN;
2630 3907 : new_st.ext.open = open;
2631 3907 : 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 3094 : gfc_free_close (gfc_close *close)
2646 : {
2647 3094 : if (close == NULL)
2648 : return;
2649 :
2650 3094 : gfc_free_expr (close->unit);
2651 3094 : gfc_free_expr (close->iomsg);
2652 3094 : gfc_free_expr (close->iostat);
2653 3094 : gfc_free_expr (close->status);
2654 3094 : free (close);
2655 : }
2656 :
2657 :
2658 : /* Match elements of a CLOSE statement. */
2659 :
2660 : static match
2661 4566 : match_close_element (gfc_close *close)
2662 : {
2663 4566 : match m;
2664 :
2665 4566 : m = match_etag (&tag_unit, &close->unit);
2666 4566 : if (m != MATCH_NO)
2667 : return m;
2668 4255 : m = match_etag (&tag_status, &close->status);
2669 4255 : if (m != MATCH_NO)
2670 : return m;
2671 2848 : m = match_etag (&tag_iomsg, &close->iomsg);
2672 2848 : if (m != MATCH_NO)
2673 : return m;
2674 2819 : m = match_out_tag (&tag_iostat, &close->iostat);
2675 2819 : if (m != MATCH_NO)
2676 : return m;
2677 2792 : m = match_ltag (&tag_err, &close->err);
2678 2792 : if (m != MATCH_NO)
2679 : return m;
2680 :
2681 : return MATCH_NO;
2682 : }
2683 :
2684 :
2685 : /* Match a CLOSE statement. */
2686 :
2687 : match
2688 3094 : gfc_match_close (void)
2689 : {
2690 3094 : gfc_close *close;
2691 3094 : match m;
2692 :
2693 3094 : m = gfc_match_char ('(');
2694 3094 : if (m == MATCH_NO)
2695 : return m;
2696 :
2697 3094 : close = XCNEW (gfc_close);
2698 :
2699 3094 : m = match_close_element (close);
2700 :
2701 3094 : if (m == MATCH_ERROR)
2702 0 : goto cleanup;
2703 3094 : if (m == MATCH_NO)
2704 : {
2705 2782 : m = gfc_match_expr (&close->unit);
2706 2782 : if (m == MATCH_NO)
2707 0 : goto syntax;
2708 2782 : if (m == MATCH_ERROR)
2709 0 : goto cleanup;
2710 : }
2711 :
2712 4566 : for (;;)
2713 : {
2714 4566 : 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 3094 : if (gfc_match_eos () == MATCH_NO)
2727 0 : goto syntax;
2728 :
2729 3094 : 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 3094 : gfc_unset_implicit_pure (NULL);
2736 :
2737 3094 : new_st.op = EXEC_CLOSE;
2738 3094 : new_st.ext.close = close;
2739 3094 : 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 3064 : check_close_constraints (gfc_close *close, locus *where)
2752 : {
2753 3064 : bool warn = (close->iostat || close->err) ? true : false;
2754 :
2755 3064 : 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 3063 : if (close->unit->expr_type == EXPR_CONSTANT
2762 2792 : && close->unit->ts.type == BT_INTEGER
2763 2792 : && 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 3063 : 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 3094 : gfc_resolve_close (gfc_close *close, locus *where)
2787 : {
2788 3094 : RESOLVE_TAG (&tag_unit, close->unit);
2789 3094 : RESOLVE_TAG (&tag_iomsg, close->iomsg);
2790 3077 : RESOLVE_TAG (&tag_iostat, close->iostat);
2791 3075 : RESOLVE_TAG (&tag_status, close->status);
2792 :
2793 3064 : if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
2794 : return false;
2795 :
2796 3064 : return check_close_constraints (close, where);
2797 : }
2798 :
2799 :
2800 : /* Free a gfc_filepos structure. */
2801 :
2802 : void
2803 2825 : gfc_free_filepos (gfc_filepos *fp)
2804 : {
2805 2825 : gfc_free_expr (fp->unit);
2806 2825 : gfc_free_expr (fp->iomsg);
2807 2825 : gfc_free_expr (fp->iostat);
2808 2825 : free (fp);
2809 2825 : }
2810 :
2811 :
2812 : /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2813 :
2814 : static match
2815 2522 : match_file_element (gfc_filepos *fp)
2816 : {
2817 2522 : match m;
2818 :
2819 2522 : m = match_etag (&tag_unit, &fp->unit);
2820 2522 : if (m != MATCH_NO)
2821 : return m;
2822 2489 : m = match_etag (&tag_iomsg, &fp->iomsg);
2823 2489 : if (m != MATCH_NO)
2824 : return m;
2825 2401 : m = match_out_tag (&tag_iostat, &fp->iostat);
2826 2401 : if (m != MATCH_NO)
2827 : return m;
2828 2323 : m = match_ltag (&tag_err, &fp->err);
2829 2323 : 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 2825 : match_filepos (gfc_statement st, gfc_exec_op op)
2841 : {
2842 2825 : gfc_filepos *fp;
2843 2825 : match m;
2844 :
2845 2825 : fp = XCNEW (gfc_filepos);
2846 :
2847 2825 : 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 2345 : m = match_file_element (fp);
2859 2345 : if (m == MATCH_ERROR)
2860 8 : goto cleanup;
2861 2337 : if (m == MATCH_NO)
2862 : {
2863 2299 : m = gfc_match_expr (&fp->unit);
2864 2299 : if (m == MATCH_ERROR || m == MATCH_NO)
2865 8 : goto syntax;
2866 : }
2867 :
2868 2506 : for (;;)
2869 : {
2870 2506 : 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 2329 : done:
2883 2809 : if (gfc_match_eos () != MATCH_YES)
2884 0 : goto syntax;
2885 :
2886 2809 : 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 2809 : gfc_unset_implicit_pure (NULL);
2895 :
2896 2809 : new_st.op = op;
2897 2809 : new_st.ext.filepos = fp;
2898 2809 : 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 2809 : gfc_resolve_filepos (gfc_filepos *fp, locus *where)
2911 : {
2912 2809 : RESOLVE_TAG (&tag_unit, fp->unit);
2913 2809 : RESOLVE_TAG (&tag_iostat, fp->iostat);
2914 2806 : RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2915 :
2916 2748 : 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 2743 : if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
2923 : return false;
2924 :
2925 2743 : if (fp->unit->expr_type == EXPR_CONSTANT
2926 2554 : && fp->unit->ts.type == BT_INTEGER
2927 2554 : && 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 2239 : gfc_match_rewind (void)
2955 : {
2956 2239 : 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 11716 : default_unit (io_kind k)
2974 : {
2975 11716 : int unit;
2976 :
2977 11716 : if (k == M_READ)
2978 : unit = 5;
2979 : else
2980 11638 : unit = 6;
2981 :
2982 11716 : 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 25691 : match_dt_unit (io_kind k, gfc_dt *dt)
2990 : {
2991 25691 : gfc_expr *e;
2992 25691 : char c;
2993 :
2994 25691 : if (gfc_match_char ('*') == MATCH_YES)
2995 : {
2996 3962 : if (dt->io_unit != NULL)
2997 0 : goto conflict;
2998 :
2999 3962 : dt->io_unit = default_unit (k);
3000 :
3001 3962 : c = gfc_peek_ascii_char ();
3002 3962 : if (c == ')')
3003 0 : gfc_error_now ("Missing format with default unit at %C");
3004 :
3005 3962 : return MATCH_YES;
3006 : }
3007 :
3008 21729 : if (gfc_match_expr (&e) == MATCH_YES)
3009 : {
3010 21729 : if (dt->io_unit != NULL)
3011 : {
3012 0 : gfc_free_expr (e);
3013 0 : goto conflict;
3014 : }
3015 :
3016 21729 : dt->io_unit = e;
3017 21729 : 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 30094 : match_dt_format (gfc_dt *dt)
3032 : {
3033 30094 : locus where;
3034 30094 : gfc_expr *e;
3035 30094 : gfc_st_label *label;
3036 30094 : match m;
3037 :
3038 30094 : where = gfc_current_locus;
3039 :
3040 30094 : if (gfc_match_char ('*') == MATCH_YES)
3041 : {
3042 15608 : if (dt->format_expr != NULL || dt->format_label != NULL)
3043 0 : goto conflict;
3044 :
3045 15608 : dt->format_label = &format_asterisk;
3046 15608 : return MATCH_YES;
3047 : }
3048 :
3049 14486 : if ((m = gfc_match_st_label (&label)) == MATCH_YES)
3050 : {
3051 1772 : 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 1772 : gfc_gobble_whitespace ();
3059 1772 : c = gfc_peek_ascii_char ();
3060 1772 : if (c == '.' || c == '_')
3061 2 : gfc_current_locus = where;
3062 : else
3063 : {
3064 1770 : if (dt->format_expr != NULL || dt->format_label != NULL)
3065 : {
3066 0 : gfc_free_st_label (label);
3067 0 : goto conflict;
3068 : }
3069 :
3070 1770 : if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
3071 : return MATCH_ERROR;
3072 :
3073 1765 : dt->format_label = label;
3074 1765 : return MATCH_YES;
3075 : }
3076 : }
3077 12714 : else if (m == MATCH_ERROR)
3078 : /* The label was zero or too large. Emit the correct diagnosis. */
3079 : return MATCH_ERROR;
3080 :
3081 12714 : if (gfc_match_expr (&e) == MATCH_YES)
3082 : {
3083 12287 : if (dt->format_expr != NULL || dt->format_label != NULL)
3084 : {
3085 0 : gfc_free_expr (e);
3086 0 : goto conflict;
3087 : }
3088 12287 : dt->format_expr = e;
3089 12287 : return MATCH_YES;
3090 : }
3091 :
3092 427 : gfc_current_locus = where; /* The only case where we have to restore */
3093 :
3094 427 : 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 3020 : dtio_procs_present (gfc_symbol *sym, io_kind k)
3105 : {
3106 3020 : gfc_symbol *derived;
3107 :
3108 3020 : if (sym && sym->ts.u.derived)
3109 : {
3110 1563 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
3111 22 : derived = CLASS_DATA (sym)->ts.u.derived;
3112 1541 : else if (sym->ts.type == BT_DERIVED)
3113 : derived = sym->ts.u.derived;
3114 : else
3115 : return false;
3116 1150 : if ((k == M_WRITE || k == M_PRINT) &&
3117 345 : (gfc_find_specific_dtio_proc (derived, true, true) != NULL))
3118 : return true;
3119 1210 : if ((k == M_READ) &&
3120 460 : (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 867 : check_namelist (gfc_symbol *sym)
3132 : {
3133 867 : gfc_namelist *p;
3134 :
3135 2903 : for (p = sym->namelist; p; p = p->next)
3136 2037 : 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 53988 : match_dt_element (io_kind k, gfc_dt *dt)
3151 : {
3152 53988 : char name[GFC_MAX_SYMBOL_LEN + 1];
3153 53988 : gfc_symbol *sym;
3154 53988 : match m;
3155 :
3156 53988 : if (gfc_match (" unit =") == MATCH_YES)
3157 : {
3158 1211 : m = match_dt_unit (k, dt);
3159 1211 : if (m != MATCH_NO)
3160 : return m;
3161 : }
3162 :
3163 52777 : if (gfc_match (" fmt =") == MATCH_YES)
3164 : {
3165 2006 : m = match_dt_format (dt);
3166 2006 : if (m != MATCH_NO)
3167 : return m;
3168 : }
3169 :
3170 50771 : if (gfc_match (" nml = %n", name) == MATCH_YES)
3171 : {
3172 770 : if (dt->namelist != NULL)
3173 : {
3174 0 : gfc_error ("Duplicate NML specification at %C");
3175 0 : return MATCH_ERROR;
3176 : }
3177 :
3178 770 : if (gfc_find_symbol (name, NULL, 1, &sym))
3179 : return MATCH_ERROR;
3180 :
3181 770 : if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
3182 : {
3183 0 : gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3184 : sym != NULL ? sym->name : name);
3185 0 : return MATCH_ERROR;
3186 : }
3187 :
3188 770 : dt->namelist = sym;
3189 770 : if (k == M_READ && check_namelist (sym))
3190 : return MATCH_ERROR;
3191 :
3192 770 : return MATCH_YES;
3193 : }
3194 :
3195 50001 : m = match_etag (&tag_e_async, &dt->asynchronous);
3196 50001 : if (m != MATCH_NO)
3197 : return m;
3198 49772 : m = match_etag (&tag_e_blank, &dt->blank);
3199 49772 : if (m != MATCH_NO)
3200 : return m;
3201 49731 : m = match_etag (&tag_e_delim, &dt->delim);
3202 49731 : if (m != MATCH_NO)
3203 : return m;
3204 49702 : m = match_etag (&tag_e_pad, &dt->pad);
3205 49702 : if (m != MATCH_NO)
3206 : return m;
3207 49597 : m = match_etag (&tag_e_sign, &dt->sign);
3208 49597 : if (m != MATCH_NO)
3209 : return m;
3210 49558 : m = match_etag (&tag_e_round, &dt->round);
3211 49558 : if (m != MATCH_NO)
3212 : return m;
3213 49219 : m = match_out_tag (&tag_id, &dt->id);
3214 49219 : if (m != MATCH_NO)
3215 : return m;
3216 49198 : m = match_etag (&tag_e_decimal, &dt->decimal);
3217 49198 : if (m != MATCH_NO)
3218 : return m;
3219 49030 : m = match_etag (&tag_rec, &dt->rec);
3220 49030 : if (m != MATCH_NO)
3221 : return m;
3222 48530 : m = match_etag (&tag_spos, &dt->pos);
3223 48530 : if (m != MATCH_NO)
3224 : return m;
3225 48358 : m = match_etag (&tag_iomsg, &dt->iomsg);
3226 48358 : if (m != MATCH_NO)
3227 : return m;
3228 :
3229 47903 : m = match_out_tag (&tag_iostat, &dt->iostat);
3230 47903 : if (m != MATCH_NO)
3231 : return m;
3232 46112 : m = match_ltag (&tag_err, &dt->err);
3233 46112 : if (m == MATCH_YES)
3234 250 : dt->err_where = gfc_current_locus;
3235 46112 : if (m != MATCH_NO)
3236 : return m;
3237 45862 : m = match_etag (&tag_advance, &dt->advance);
3238 45862 : if (m != MATCH_NO)
3239 : return m;
3240 45479 : m = match_out_tag (&tag_size, &dt->size);
3241 45479 : if (m != MATCH_NO)
3242 : return m;
3243 :
3244 45414 : m = match_ltag (&tag_end, &dt->end);
3245 45414 : if (m == MATCH_YES)
3246 : {
3247 562 : if (k == M_WRITE)
3248 : {
3249 4 : gfc_error ("END tag at %C not allowed in output statement");
3250 4 : return MATCH_ERROR;
3251 : }
3252 558 : dt->end_where = gfc_current_locus;
3253 : }
3254 45410 : if (m != MATCH_NO)
3255 : return m;
3256 :
3257 44852 : m = match_ltag (&tag_eor, &dt->eor);
3258 44852 : if (m == MATCH_YES)
3259 34 : dt->eor_where = gfc_current_locus;
3260 44852 : if (m != MATCH_NO)
3261 : return m;
3262 :
3263 : return MATCH_NO;
3264 : }
3265 :
3266 :
3267 : /* Free a data transfer structure and everything below it. */
3268 :
3269 : void
3270 66575 : gfc_free_dt (gfc_dt *dt)
3271 : {
3272 66575 : if (dt == NULL)
3273 : return;
3274 :
3275 33356 : gfc_free_expr (dt->io_unit);
3276 33356 : gfc_free_expr (dt->format_expr);
3277 33356 : gfc_free_expr (dt->rec);
3278 33356 : gfc_free_expr (dt->advance);
3279 33356 : gfc_free_expr (dt->iomsg);
3280 33356 : gfc_free_expr (dt->iostat);
3281 33356 : gfc_free_expr (dt->size);
3282 33356 : gfc_free_expr (dt->pad);
3283 33356 : gfc_free_expr (dt->delim);
3284 33356 : gfc_free_expr (dt->sign);
3285 33356 : gfc_free_expr (dt->round);
3286 33356 : gfc_free_expr (dt->blank);
3287 33356 : gfc_free_expr (dt->decimal);
3288 33356 : gfc_free_expr (dt->pos);
3289 33356 : gfc_free_expr (dt->dt_io_kind);
3290 : /* dt->extra_comma is a link to dt_io_kind if it is set. */
3291 33356 : free (dt);
3292 : }
3293 :
3294 :
3295 : static const char *
3296 : io_kind_name (io_kind k);
3297 :
3298 : static bool
3299 : check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3300 : locus *spec_end);
3301 :
3302 : /* Resolve everything in a gfc_dt structure. */
3303 :
3304 : bool
3305 33285 : gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc)
3306 : {
3307 33285 : gfc_expr *e;
3308 33285 : io_kind k;
3309 33285 : bool internal_unit;
3310 :
3311 : /* This is set in any case. */
3312 33285 : gcc_assert (dt->dt_io_kind);
3313 33285 : k = dt->dt_io_kind->value.iokind;
3314 :
3315 33285 : RESOLVE_TAG (&tag_format, dt->format_expr);
3316 33257 : RESOLVE_TAG (&tag_rec, dt->rec);
3317 33257 : RESOLVE_TAG (&tag_spos, dt->pos);
3318 33257 : RESOLVE_TAG (&tag_advance, dt->advance);
3319 33254 : RESOLVE_TAG (&tag_id, dt->id);
3320 33254 : RESOLVE_TAG (&tag_iomsg, dt->iomsg);
3321 33225 : RESOLVE_TAG (&tag_iostat, dt->iostat);
3322 33222 : RESOLVE_TAG (&tag_size, dt->size);
3323 33218 : RESOLVE_TAG (&tag_e_pad, dt->pad);
3324 33196 : RESOLVE_TAG (&tag_e_delim, dt->delim);
3325 33174 : RESOLVE_TAG (&tag_e_sign, dt->sign);
3326 33152 : RESOLVE_TAG (&tag_e_round, dt->round);
3327 33130 : RESOLVE_TAG (&tag_e_blank, dt->blank);
3328 33108 : RESOLVE_TAG (&tag_e_decimal, dt->decimal);
3329 33088 : RESOLVE_TAG (&tag_e_async, dt->asynchronous);
3330 :
3331 : /* Check I/O constraints.
3332 : To validate NAMELIST we need to check if we were also given an I/O list,
3333 : which is stored in code->block->next with op EXEC_TRANSFER.
3334 : Note that the I/O list was already resolved from resolve_transfer. */
3335 33065 : gfc_code *io_code = NULL;
3336 33065 : if (dt_code && dt_code->block && dt_code->block->next
3337 33065 : && dt_code->block->next->op == EXEC_TRANSFER)
3338 33065 : io_code = dt_code->block->next;
3339 :
3340 33065 : if (!check_io_constraints (k, dt, io_code, loc))
3341 : return false;
3342 :
3343 33006 : e = dt->io_unit;
3344 33006 : if (e == NULL)
3345 : {
3346 2 : gfc_error ("UNIT not specified at %L", loc);
3347 2 : return false;
3348 : }
3349 :
3350 33004 : if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER
3351 365 : && e->ts.type == BT_CHARACTER)
3352 : {
3353 4 : gfc_error ("UNIT specification at %L must "
3354 : "not be a character PARAMETER", &e->where);
3355 4 : return false;
3356 : }
3357 :
3358 33000 : internal_unit = false;
3359 33000 : if (gfc_resolve_expr (e)
3360 33000 : && (e->ts.type != BT_INTEGER
3361 9993 : && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
3362 : {
3363 : /* If there is no extra comma signifying the "format" form of the IO
3364 : statement, then this must be an error. */
3365 2 : if (!dt->extra_comma)
3366 : {
3367 1 : gfc_error ("UNIT specification at %L must be an INTEGER expression "
3368 : "or a CHARACTER variable", &e->where);
3369 1 : return false;
3370 : }
3371 : else
3372 : {
3373 : /* At this point, we have an extra comma. If io_unit has arrived as
3374 : type character, we assume its really the "format" form of the I/O
3375 : statement. We set the io_unit to the default unit and format to
3376 : the character expression. See F95 Standard section 9.4. */
3377 1 : if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
3378 : {
3379 0 : dt->format_expr = dt->io_unit;
3380 0 : dt->io_unit = default_unit (k);
3381 :
3382 : /* Nullify this pointer now so that a warning/error is not
3383 : triggered below for the "Extension". */
3384 0 : dt->extra_comma = NULL;
3385 : }
3386 :
3387 1 : if (k == M_WRITE)
3388 : {
3389 1 : gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3390 1 : &dt->extra_comma->where);
3391 1 : return false;
3392 : }
3393 : }
3394 : }
3395 :
3396 32998 : if (e->ts.type == BT_CHARACTER)
3397 : {
3398 9991 : internal_unit = true;
3399 9991 : if (gfc_has_vector_index (e))
3400 : {
3401 3 : gfc_error ("Internal unit with vector subscript at %L", &e->where);
3402 3 : return false;
3403 : }
3404 :
3405 : /* If we are writing, make sure the internal unit can be changed. */
3406 9988 : gcc_assert (k != M_PRINT);
3407 9988 : if (k == M_WRITE)
3408 : {
3409 8088 : if (!gfc_check_vardef_context (e, false, false, false,
3410 8088 : _("internal unit in WRITE")))
3411 : return false;
3412 :
3413 8087 : gfc_expr_set_at (e, &e->where, VALUE_VARDEF);
3414 : }
3415 : }
3416 :
3417 32994 : if (e->rank && e->ts.type != BT_CHARACTER)
3418 : {
3419 1 : gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
3420 1 : return false;
3421 : }
3422 :
3423 32993 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
3424 21485 : && mpz_sgn (e->value.integer) < 0)
3425 : {
3426 0 : gfc_error ("UNIT number in statement at %L must be non-negative",
3427 : &e->where);
3428 0 : return false;
3429 : }
3430 :
3431 32993 : if (!internal_unit)
3432 23006 : gfc_value_used_expr (e, VALUE_USED);
3433 :
3434 : /* If we are reading and have a namelist, check that all namelist symbols
3435 : can appear in a variable definition context. */
3436 32993 : if (dt->namelist)
3437 : {
3438 1193 : gfc_namelist* n;
3439 4208 : for (n = dt->namelist->namelist; n; n = n->next)
3440 : {
3441 3021 : gfc_expr* e;
3442 3021 : bool t;
3443 :
3444 3021 : if (k == M_READ)
3445 : {
3446 2035 : e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
3447 2035 : t = gfc_check_vardef_context (e, false, false, false, NULL);
3448 2035 : gfc_free_expr (e);
3449 :
3450 2035 : if (!t)
3451 : {
3452 1 : gfc_error ("NAMELIST %qs in READ statement at %L contains"
3453 : " the symbol %qs which may not appear in a"
3454 : " variable definition context",
3455 1 : dt->namelist->name, loc, n->sym->name);
3456 1 : return false;
3457 : }
3458 2034 : gfc_value_set_at (n->sym, NULL, VALUE_VARDEF);
3459 : }
3460 :
3461 3020 : t = dtio_procs_present (n->sym, k);
3462 :
3463 3020 : if (n->sym->ts.type == BT_CLASS && !t)
3464 : {
3465 3 : gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3466 : "polymorphic and requires a defined input/output "
3467 3 : "procedure", n->sym->name, dt->namelist->name, loc);
3468 3 : return false;
3469 : }
3470 :
3471 3017 : if ((n->sym->ts.type == BT_DERIVED)
3472 783 : && (n->sym->ts.u.derived->attr.alloc_comp
3473 781 : || n->sym->ts.u.derived->attr.pointer_comp))
3474 : {
3475 2 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
3476 : "namelist %qs at %L with ALLOCATABLE "
3477 : "or POINTER components", n->sym->name,
3478 2 : dt->namelist->name, loc))
3479 : return false;
3480 :
3481 2 : if (!t)
3482 : {
3483 2 : gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3484 : "ALLOCATABLE or POINTER components and thus requires "
3485 2 : "a defined input/output procedure", n->sym->name,
3486 2 : dt->namelist->name, loc);
3487 2 : return false;
3488 : }
3489 : }
3490 : }
3491 : }
3492 :
3493 32987 : if (dt->extra_comma
3494 32987 : && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L",
3495 : &dt->extra_comma->where))
3496 : return false;
3497 :
3498 32987 : if (dt->err)
3499 : {
3500 250 : if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
3501 : return false;
3502 250 : if (dt->err->defined == ST_LABEL_UNKNOWN)
3503 : {
3504 1 : gfc_error ("ERR tag label %d at %L not defined",
3505 : dt->err->value, &dt->err_where);
3506 1 : return false;
3507 : }
3508 : }
3509 :
3510 32986 : if (dt->end)
3511 : {
3512 557 : if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
3513 : return false;
3514 557 : if (dt->end->defined == ST_LABEL_UNKNOWN)
3515 : {
3516 1 : gfc_error ("END tag label %d at %L not defined",
3517 : dt->end->value, &dt->end_where);
3518 1 : return false;
3519 : }
3520 : }
3521 :
3522 32985 : if (dt->eor)
3523 : {
3524 31 : if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
3525 : return false;
3526 31 : if (dt->eor->defined == ST_LABEL_UNKNOWN)
3527 : {
3528 1 : gfc_error ("EOR tag label %d at %L not defined",
3529 : dt->eor->value, &dt->eor_where);
3530 1 : return false;
3531 : }
3532 : }
3533 :
3534 : /* Check the format label actually exists. */
3535 32984 : if (dt->format_label && dt->format_label != &format_asterisk
3536 1767 : && dt->format_label->defined == ST_LABEL_UNKNOWN)
3537 : {
3538 7 : gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
3539 : loc);
3540 7 : return false;
3541 : }
3542 :
3543 : return true;
3544 : }
3545 :
3546 :
3547 : /* Given an io_kind, return its name. */
3548 :
3549 : static const char *
3550 811 : io_kind_name (io_kind k)
3551 : {
3552 811 : const char *name;
3553 :
3554 811 : switch (k)
3555 : {
3556 : case M_READ:
3557 : name = "READ";
3558 : break;
3559 499 : case M_WRITE:
3560 499 : name = "WRITE";
3561 499 : break;
3562 26 : case M_PRINT:
3563 26 : name = "PRINT";
3564 26 : break;
3565 0 : case M_INQUIRE:
3566 0 : name = "INQUIRE";
3567 0 : break;
3568 0 : default:
3569 0 : gfc_internal_error ("io_kind_name(): bad I/O-kind");
3570 : }
3571 :
3572 811 : return name;
3573 : }
3574 :
3575 :
3576 : /* Match an IO iteration statement of the form:
3577 :
3578 : ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3579 :
3580 : which is equivalent to a single IO element. This function is
3581 : mutually recursive with match_io_element(). */
3582 :
3583 : static match match_io_element (io_kind, gfc_code **);
3584 :
3585 : static match
3586 48300 : match_io_iterator (io_kind k, gfc_code **result)
3587 : {
3588 48300 : gfc_code *head, *tail, *new_code;
3589 48300 : gfc_iterator *iter;
3590 48300 : locus old_loc;
3591 48300 : match m;
3592 48300 : int n;
3593 :
3594 48300 : iter = NULL;
3595 48300 : head = NULL;
3596 48300 : old_loc = gfc_current_locus;
3597 :
3598 48300 : if (gfc_match_char ('(') != MATCH_YES)
3599 : return MATCH_NO;
3600 :
3601 763 : m = match_io_element (k, &head);
3602 763 : tail = head;
3603 :
3604 763 : if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3605 : {
3606 92 : m = MATCH_NO;
3607 92 : goto cleanup;
3608 : }
3609 :
3610 : /* Can't be anything but an IO iterator. Build a list. */
3611 671 : iter = gfc_get_iterator ();
3612 :
3613 671 : for (n = 1;; n++)
3614 : {
3615 723 : m = gfc_match_iterator (iter, 0);
3616 723 : if (m == MATCH_ERROR)
3617 0 : goto cleanup;
3618 723 : if (m == MATCH_YES)
3619 : {
3620 654 : gfc_check_do_variable (iter->var->symtree);
3621 654 : break;
3622 : }
3623 :
3624 69 : m = match_io_element (k, &new_code);
3625 69 : if (m == MATCH_ERROR)
3626 0 : goto cleanup;
3627 69 : if (m == MATCH_NO)
3628 : {
3629 : if (n > 2)
3630 : goto syntax;
3631 : goto cleanup;
3632 : }
3633 :
3634 69 : tail = gfc_append_code (tail, new_code);
3635 :
3636 69 : if (gfc_match_char (',') != MATCH_YES)
3637 : {
3638 17 : if (n > 2)
3639 0 : goto syntax;
3640 17 : m = MATCH_NO;
3641 17 : goto cleanup;
3642 : }
3643 : }
3644 :
3645 654 : if (gfc_match_char (')') != MATCH_YES)
3646 1 : goto syntax;
3647 :
3648 653 : new_code = gfc_get_code (EXEC_DO);
3649 653 : new_code->ext.iterator = iter;
3650 :
3651 653 : new_code->block = gfc_get_code (EXEC_DO);
3652 653 : new_code->block->next = head;
3653 :
3654 653 : *result = new_code;
3655 653 : return MATCH_YES;
3656 :
3657 1 : syntax:
3658 1 : gfc_error ("Syntax error in I/O iterator at %C");
3659 1 : m = MATCH_ERROR;
3660 :
3661 110 : cleanup:
3662 110 : gfc_free_iterator (iter, 1);
3663 110 : gfc_free_statements (head);
3664 110 : gfc_current_locus = old_loc;
3665 110 : return m;
3666 : }
3667 :
3668 :
3669 : /* Match a single element of an IO list, which is either a single
3670 : expression or an IO Iterator. */
3671 :
3672 : static match
3673 48300 : match_io_element (io_kind k, gfc_code **cpp)
3674 : {
3675 48300 : gfc_expr *expr;
3676 48300 : gfc_code *cp;
3677 48300 : match m;
3678 :
3679 48300 : expr = NULL;
3680 :
3681 48300 : m = match_io_iterator (k, cpp);
3682 48300 : if (m == MATCH_YES)
3683 : return MATCH_YES;
3684 :
3685 47647 : if (k == M_READ)
3686 : {
3687 7488 : m = gfc_match_variable (&expr, 0);
3688 7488 : if (m == MATCH_NO)
3689 : {
3690 0 : gfc_error ("Expecting variable in READ statement at %C");
3691 0 : m = MATCH_ERROR;
3692 : }
3693 :
3694 7488 : if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT)
3695 : {
3696 1 : gfc_error ("Expecting variable or io-implied-do in READ statement "
3697 : "at %L", &expr->where);
3698 1 : m = MATCH_ERROR;
3699 : }
3700 :
3701 7488 : if (m == MATCH_YES
3702 7487 : && expr->expr_type == EXPR_VARIABLE
3703 7487 : && expr->symtree->n.sym->attr.external)
3704 : {
3705 2 : gfc_error ("Expecting variable or io-implied-do at %L",
3706 : &expr->where);
3707 2 : m = MATCH_ERROR;
3708 : }
3709 : }
3710 : else
3711 : {
3712 40159 : m = gfc_match_expr (&expr);
3713 40159 : if (m == MATCH_NO)
3714 41 : gfc_error ("Expected expression in %s statement at %C",
3715 : io_kind_name (k));
3716 :
3717 40159 : if (m == MATCH_YES && expr->ts.type == BT_BOZ)
3718 : {
3719 6 : if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in"
3720 : " an output IO list"), &gfc_current_locus))
3721 : return MATCH_ERROR;
3722 3 : if (!gfc_boz2int (expr, gfc_max_integer_kind))
3723 : return MATCH_ERROR;
3724 47644 : };
3725 : }
3726 :
3727 47644 : if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3728 : m = MATCH_ERROR;
3729 :
3730 47643 : if (m != MATCH_YES)
3731 : {
3732 142 : gfc_free_expr (expr);
3733 142 : return MATCH_ERROR;
3734 : }
3735 :
3736 47502 : cp = gfc_get_code (EXEC_TRANSFER);
3737 47502 : cp->expr1 = expr;
3738 47502 : if (k != M_INQUIRE)
3739 47348 : cp->ext.dt = current_dt;
3740 :
3741 47502 : *cpp = cp;
3742 47502 : return MATCH_YES;
3743 : }
3744 :
3745 :
3746 : /* Match an I/O list, building gfc_code structures as we go. */
3747 :
3748 : static match
3749 31360 : match_io_list (io_kind k, gfc_code **head_p)
3750 : {
3751 31360 : gfc_code *head, *tail, *new_code;
3752 31360 : match m;
3753 :
3754 31360 : *head_p = head = tail = NULL;
3755 31360 : if (gfc_match_eos () == MATCH_YES)
3756 : return MATCH_YES;
3757 :
3758 47468 : for (;;)
3759 : {
3760 47468 : m = match_io_element (k, &new_code);
3761 47468 : if (m == MATCH_ERROR)
3762 104 : goto cleanup;
3763 47364 : if (m == MATCH_NO)
3764 : goto syntax;
3765 :
3766 47364 : tail = gfc_append_code (tail, new_code);
3767 47364 : if (head == NULL)
3768 31262 : head = new_code;
3769 :
3770 47364 : if (gfc_match_eos () == MATCH_YES)
3771 : break;
3772 16117 : if (gfc_match_char (',') != MATCH_YES)
3773 9 : goto syntax;
3774 : }
3775 :
3776 31247 : *head_p = head;
3777 31247 : return MATCH_YES;
3778 :
3779 9 : syntax:
3780 9 : gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3781 :
3782 113 : cleanup:
3783 113 : gfc_free_statements (head);
3784 113 : return MATCH_ERROR;
3785 : }
3786 :
3787 :
3788 : /* Attach the data transfer end node. */
3789 :
3790 : static void
3791 33379 : terminate_io (gfc_code *io_code)
3792 : {
3793 33379 : gfc_code *c;
3794 :
3795 33379 : if (io_code == NULL)
3796 2167 : io_code = new_st.block;
3797 :
3798 33379 : c = gfc_get_code (EXEC_DT_END);
3799 :
3800 : /* Point to structure that is already there */
3801 33379 : c->ext.dt = new_st.ext.dt;
3802 33379 : gfc_append_code (io_code, c);
3803 33379 : }
3804 :
3805 :
3806 : /* Check the constraints for a data transfer statement. The majority of the
3807 : constraints appearing in 9.4 of the standard appear here.
3808 :
3809 : Tag expressions are already resolved by resolve_tag, which includes
3810 : verifying the type, that they are scalar, and verifying that BT_CHARACTER
3811 : tags are of default kind. */
3812 :
3813 : static bool
3814 33065 : check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3815 : locus *spec_end)
3816 : {
3817 : #define io_constraint(condition, msg, where)\
3818 : if (condition) \
3819 : {\
3820 : if (GFC_LOCUS_IS_SET (*where))\
3821 : gfc_error ((msg), (where));\
3822 : else\
3823 : gfc_error ((msg), spec_end);\
3824 : return false;\
3825 : }
3826 :
3827 33065 : gfc_expr *expr;
3828 33065 : gfc_symbol *sym = NULL;
3829 33065 : bool warn, unformatted;
3830 :
3831 33065 : warn = (dt->err || dt->iostat) ? true : false;
3832 20849 : unformatted = dt->format_expr == NULL && dt->format_label == NULL
3833 36668 : && dt->namelist == NULL;
3834 :
3835 33065 : expr = dt->io_unit;
3836 33065 : if (expr && expr->expr_type == EXPR_VARIABLE
3837 11522 : && expr->ts.type == BT_CHARACTER)
3838 : {
3839 9998 : sym = expr->symtree->n.sym;
3840 :
3841 9998 : io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3842 : "Internal file at %L must not be INTENT(IN)",
3843 9998 : &expr->where);
3844 :
3845 9998 : io_constraint (gfc_has_vector_index (dt->io_unit),
3846 : "Internal file incompatible with vector subscript at %L",
3847 9998 : &expr->where);
3848 :
3849 9998 : io_constraint (dt->rec != NULL,
3850 : "REC tag at %L is incompatible with internal file",
3851 9997 : &dt->rec->where);
3852 :
3853 9997 : io_constraint (dt->pos != NULL,
3854 : "POS tag at %L is incompatible with internal file",
3855 9996 : &dt->pos->where);
3856 :
3857 9996 : io_constraint (unformatted,
3858 : "Unformatted I/O not allowed with internal unit at %L",
3859 9995 : &dt->io_unit->where);
3860 :
3861 9995 : io_constraint (dt->asynchronous != NULL,
3862 : "ASYNCHRONOUS tag at %L not allowed with internal file",
3863 9995 : &dt->asynchronous->where);
3864 :
3865 9995 : if (dt->namelist != NULL)
3866 : {
3867 254 : if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3868 : "namelist", &expr->where))
3869 : return false;
3870 : }
3871 :
3872 9994 : io_constraint (dt->advance != NULL,
3873 : "ADVANCE tag at %L is incompatible with internal file",
3874 : &dt->advance->where);
3875 : }
3876 :
3877 33058 : if (expr && expr->ts.type != BT_CHARACTER)
3878 : {
3879 :
3880 23062 : if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE))
3881 : {
3882 0 : gfc_error ("IO UNIT in %s statement at %L must be "
3883 : "an internal file in a PURE procedure",
3884 : io_kind_name (k), &expr->where);
3885 0 : return false;
3886 : }
3887 :
3888 23062 : if (k == M_READ || k == M_WRITE)
3889 15455 : gfc_unset_implicit_pure (NULL);
3890 : }
3891 :
3892 33060 : if (dt->asynchronous)
3893 : {
3894 206 : int num = -1;
3895 206 : static const char * asynchronous[] = { "YES", "NO", NULL };
3896 :
3897 : /* Note: gfc_reduce_init_expr reports an error if not init-expr. */
3898 206 : if (!gfc_reduce_init_expr (dt->asynchronous))
3899 7 : return false;
3900 :
3901 201 : if (!compare_to_allowed_values
3902 201 : ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3903 : dt->asynchronous->value.character.string,
3904 201 : io_kind_name (k), warn, &dt->asynchronous->where, &num))
3905 : return false;
3906 :
3907 199 : gcc_checking_assert (num != -1);
3908 :
3909 : /* For "YES", mark related symbols as asynchronous. */
3910 199 : if (num == 0)
3911 : {
3912 : /* SIZE variable. */
3913 195 : if (dt->size)
3914 0 : dt->size->symtree->n.sym->attr.asynchronous = 1;
3915 :
3916 : /* Variables in a NAMELIST. */
3917 195 : if (dt->namelist)
3918 4 : for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next)
3919 3 : nl->sym->attr.asynchronous = 1;
3920 :
3921 : /* Variables in an I/O list. */
3922 430 : for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER;
3923 235 : xfer = xfer->next)
3924 : {
3925 235 : gfc_expr *expr = xfer->expr1;
3926 470 : while (expr != NULL && expr->expr_type == EXPR_OP
3927 241 : && expr->value.op.op == INTRINSIC_PARENTHESES)
3928 0 : expr = expr->value.op.op1;
3929 :
3930 235 : if (expr && expr->expr_type == EXPR_VARIABLE)
3931 157 : expr->symtree->n.sym->attr.asynchronous = 1;
3932 : }
3933 : }
3934 : }
3935 :
3936 33053 : if (dt->id)
3937 : {
3938 21 : bool not_yes
3939 21 : = !dt->asynchronous
3940 20 : || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3941 40 : || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3942 33053 : "yes", 3) != 0;
3943 2 : io_constraint (not_yes,
3944 : "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3945 : "specifier", &dt->id->where);
3946 : }
3947 :
3948 33051 : if (dt->decimal)
3949 : {
3950 145 : if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
3951 : "not allowed in Fortran 95", &dt->decimal->where))
3952 : return false;
3953 :
3954 145 : if (dt->decimal->expr_type == EXPR_CONSTANT)
3955 : {
3956 127 : static const char * decimal[] = { "COMMA", "POINT", NULL };
3957 :
3958 127 : if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3959 : dt->decimal->value.character.string,
3960 : io_kind_name (k), warn,
3961 : &dt->decimal->where))
3962 : return false;
3963 :
3964 123 : io_constraint (unformatted,
3965 : "the DECIMAL= specifier at %L must be with an "
3966 : "explicit format expression", &dt->decimal->where);
3967 : }
3968 : }
3969 :
3970 33047 : if (dt->blank)
3971 : {
3972 17 : if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
3973 : "not allowed in Fortran 95", &dt->blank->where))
3974 : return false;
3975 :
3976 17 : if (dt->blank->expr_type == EXPR_CONSTANT)
3977 : {
3978 16 : static const char * blank[] = { "NULL", "ZERO", NULL };
3979 :
3980 :
3981 16 : if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3982 : dt->blank->value.character.string,
3983 : io_kind_name (k), warn,
3984 : &dt->blank->where))
3985 : return false;
3986 :
3987 12 : io_constraint (unformatted,
3988 : "the BLANK= specifier at %L must be with an "
3989 : "explicit format expression", &dt->blank->where);
3990 : }
3991 : }
3992 :
3993 33043 : if (dt->pad)
3994 : {
3995 83 : if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L "
3996 : "not allowed in Fortran 95", &dt->pad->where))
3997 : return false;
3998 :
3999 83 : if (dt->pad->expr_type == EXPR_CONSTANT)
4000 : {
4001 83 : static const char * pad[] = { "YES", "NO", NULL };
4002 :
4003 83 : if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
4004 : dt->pad->value.character.string,
4005 : io_kind_name (k), warn,
4006 : &dt->pad->where))
4007 : return false;
4008 :
4009 81 : io_constraint (unformatted,
4010 : "the PAD= specifier at %L must be with an "
4011 : "explicit format expression", &dt->pad->where);
4012 : }
4013 : }
4014 :
4015 33039 : if (dt->round)
4016 : {
4017 317 : if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
4018 : "not allowed in Fortran 95", &dt->round->where))
4019 : return false;
4020 :
4021 317 : if (dt->round->expr_type == EXPR_CONSTANT)
4022 : {
4023 305 : static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
4024 : "COMPATIBLE", "PROCESSOR_DEFINED",
4025 : NULL };
4026 :
4027 305 : if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
4028 : dt->round->value.character.string,
4029 : io_kind_name (k), warn,
4030 : &dt->round->where))
4031 : return false;
4032 : }
4033 : }
4034 :
4035 33035 : if (dt->sign)
4036 : {
4037 : /* When implemented, change the following to use gfc_notify_std F2003.
4038 : if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
4039 : "not allowed in Fortran 95", &dt->sign->where) == false)
4040 : return false; */
4041 :
4042 17 : if (dt->sign->expr_type == EXPR_CONSTANT)
4043 : {
4044 16 : static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
4045 : NULL };
4046 :
4047 16 : if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
4048 : dt->sign->value.character.string,
4049 : io_kind_name (k), warn, &dt->sign->where))
4050 : return false;
4051 :
4052 12 : io_constraint (unformatted,
4053 : "SIGN= specifier at %L must be with an "
4054 12 : "explicit format expression", &dt->sign->where);
4055 :
4056 12 : io_constraint (k == M_READ,
4057 : "SIGN= specifier at %L not allowed in a "
4058 : "READ statement", &dt->sign->where);
4059 : }
4060 : }
4061 :
4062 33031 : if (dt->delim)
4063 : {
4064 7 : if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L "
4065 : "not allowed in Fortran 95", &dt->delim->where))
4066 : return false;
4067 :
4068 6 : if (dt->delim->expr_type == EXPR_CONSTANT)
4069 : {
4070 6 : static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
4071 :
4072 6 : if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
4073 : dt->delim->value.character.string,
4074 : io_kind_name (k), warn,
4075 : &dt->delim->where))
4076 : return false;
4077 :
4078 2 : io_constraint (k == M_READ,
4079 : "DELIM= specifier at %L not allowed in a "
4080 2 : "READ statement", &dt->delim->where);
4081 :
4082 2 : io_constraint (dt->format_label != &format_asterisk
4083 : && dt->namelist == NULL,
4084 : "DELIM= specifier at %L must have FMT=*",
4085 2 : &dt->delim->where);
4086 :
4087 2 : io_constraint (unformatted && dt->namelist == NULL,
4088 : "DELIM= specifier at %L must be with FMT=* or "
4089 : "NML= specifier", &dt->delim->where);
4090 : }
4091 : }
4092 :
4093 33026 : if (dt->namelist)
4094 : {
4095 1197 : io_constraint (io_code && dt->namelist,
4096 : "NAMELIST cannot be followed by IO-list at %L",
4097 1196 : &io_code->loc);
4098 :
4099 1196 : io_constraint (dt->format_expr,
4100 : "IO spec-list cannot contain both NAMELIST group name "
4101 : "and format specification at %L",
4102 1195 : &dt->format_expr->where);
4103 :
4104 1195 : io_constraint (dt->format_label,
4105 : "IO spec-list cannot contain both NAMELIST group name "
4106 1194 : "and format label at %L", spec_end);
4107 :
4108 1194 : io_constraint (dt->rec,
4109 : "NAMELIST IO is not allowed with a REC= specifier "
4110 1194 : "at %L", &dt->rec->where);
4111 :
4112 1194 : io_constraint (dt->advance,
4113 : "NAMELIST IO is not allowed with a ADVANCE= specifier "
4114 : "at %L", &dt->advance->where);
4115 : }
4116 :
4117 33022 : if (dt->rec)
4118 : {
4119 499 : io_constraint (dt->end,
4120 : "An END tag is not allowed with a "
4121 498 : "REC= specifier at %L", &dt->end_where);
4122 :
4123 498 : io_constraint (dt->format_label == &format_asterisk,
4124 : "FMT=* is not allowed with a REC= specifier "
4125 497 : "at %L", spec_end);
4126 :
4127 497 : io_constraint (dt->pos,
4128 : "POS= is not allowed with REC= specifier "
4129 : "at %L", &dt->pos->where);
4130 : }
4131 :
4132 33018 : if (dt->advance)
4133 : {
4134 373 : int not_yes, not_no;
4135 373 : expr = dt->advance;
4136 :
4137 373 : io_constraint (dt->format_label == &format_asterisk,
4138 : "List directed format(*) is not allowed with a "
4139 373 : "ADVANCE= specifier at %L.", &expr->where);
4140 :
4141 373 : io_constraint (unformatted,
4142 : "the ADVANCE= specifier at %L must appear with an "
4143 372 : "explicit format expression", &expr->where);
4144 :
4145 372 : if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
4146 : {
4147 353 : const gfc_char_t *advance = expr->value.character.string;
4148 353 : not_no = gfc_wide_strlen (advance) != 2
4149 353 : || gfc_wide_strncasecmp (advance, "no", 2) != 0;
4150 353 : not_yes = gfc_wide_strlen (advance) != 3
4151 353 : || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
4152 353 : }
4153 : else
4154 : {
4155 : not_no = 0;
4156 : not_yes = 0;
4157 : }
4158 :
4159 372 : io_constraint (not_no && not_yes,
4160 : "ADVANCE= specifier at %L must have value = "
4161 368 : "YES or NO.", &expr->where);
4162 :
4163 368 : io_constraint (dt->size && not_no && k == M_READ,
4164 : "SIZE tag at %L requires an ADVANCE = %<NO%>",
4165 367 : &dt->size->where);
4166 :
4167 367 : io_constraint (dt->eor && not_no && k == M_READ,
4168 : "EOR tag at %L requires an ADVANCE = %<NO%>",
4169 : &dt->eor_where);
4170 : }
4171 :
4172 33011 : if (k != M_READ)
4173 : {
4174 26709 : io_constraint (dt->end, "END tag not allowed with output at %L",
4175 26708 : &dt->end_where);
4176 :
4177 26708 : io_constraint (dt->eor, "EOR tag not allowed with output at %L",
4178 26706 : &dt->eor_where);
4179 :
4180 26706 : io_constraint (dt->blank,
4181 : "BLANK= specifier not allowed with output at %L",
4182 26706 : &dt->blank->where);
4183 :
4184 26706 : io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
4185 26706 : &dt->pad->where);
4186 :
4187 26706 : io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
4188 : &dt->size->where);
4189 : }
4190 : else
4191 : {
4192 6302 : io_constraint (dt->size && dt->advance == NULL,
4193 : "SIZE tag at %L requires an ADVANCE tag",
4194 6302 : &dt->size->where);
4195 :
4196 6302 : io_constraint (dt->eor && dt->advance == NULL,
4197 : "EOR tag at %L requires an ADVANCE tag",
4198 : &dt->eor_where);
4199 : }
4200 :
4201 : return true;
4202 : #undef io_constraint
4203 : }
4204 :
4205 :
4206 : /* Match a READ, WRITE or PRINT statement. */
4207 :
4208 : static match
4209 33459 : match_io (io_kind k)
4210 : {
4211 33459 : char name[GFC_MAX_SYMBOL_LEN + 1];
4212 33459 : gfc_code *io_code;
4213 33459 : gfc_symbol *sym;
4214 33459 : int comma_flag;
4215 33459 : locus where;
4216 33459 : locus control;
4217 33459 : gfc_dt *dt;
4218 33459 : match m;
4219 :
4220 33459 : where = gfc_current_locus;
4221 33459 : comma_flag = 0;
4222 33459 : current_dt = dt = XCNEW (gfc_dt);
4223 33459 : m = gfc_match_char ('(');
4224 33459 : if (m == MATCH_NO)
4225 : {
4226 7753 : where = gfc_current_locus;
4227 7753 : if (k == M_WRITE)
4228 0 : goto syntax;
4229 7753 : else if (k == M_PRINT)
4230 : {
4231 : /* Treat the non-standard case of PRINT namelist. */
4232 7459 : if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
4233 14962 : && gfc_match_name (name) == MATCH_YES)
4234 : {
4235 131 : gfc_find_symbol (name, NULL, 1, &sym);
4236 131 : if (sym && sym->attr.flavor == FL_NAMELIST)
4237 : {
4238 11 : if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
4239 : "%C is an extension"))
4240 : {
4241 2 : m = MATCH_ERROR;
4242 2 : goto cleanup;
4243 : }
4244 :
4245 9 : dt->io_unit = default_unit (k);
4246 9 : dt->namelist = sym;
4247 9 : goto get_io_list;
4248 : }
4249 : else
4250 120 : gfc_current_locus = where;
4251 : }
4252 :
4253 7728 : if (gfc_match_char ('*') == MATCH_YES
4254 7728 : && gfc_match_char(',') == MATCH_YES)
4255 : {
4256 6933 : locus where2 = gfc_current_locus;
4257 6933 : if (gfc_match_eos () == MATCH_YES)
4258 : {
4259 1 : gfc_current_locus = where2;
4260 1 : gfc_error ("Comma after * at %C not allowed without I/O list");
4261 1 : m = MATCH_ERROR;
4262 1 : goto cleanup;
4263 : }
4264 : else
4265 6932 : gfc_current_locus = where;
4266 : }
4267 : else
4268 795 : gfc_current_locus = where;
4269 : }
4270 :
4271 7741 : if (gfc_current_form == FORM_FREE)
4272 : {
4273 7463 : char c = gfc_peek_ascii_char ();
4274 :
4275 : /* Issue a warning for an invalid tab in 'print<tab>*'. After
4276 : the warning is issued, consume any other whitespace and check
4277 : that the next char is an *, ', or ". */
4278 7463 : if (c == '\t')
4279 : {
4280 2 : gfc_gobble_whitespace ();
4281 2 : c = gfc_peek_ascii_char ();
4282 2 : if (c != '*' && c != '\'' && c != '"')
4283 : {
4284 0 : m = MATCH_NO;
4285 0 : goto cleanup;
4286 : }
4287 : }
4288 7461 : else if (c != ' ' && c != '*' && c != '\'' && c != '"')
4289 : {
4290 2 : m = MATCH_NO;
4291 2 : goto cleanup;
4292 : }
4293 : }
4294 :
4295 7739 : m = match_dt_format (dt);
4296 7739 : if (m == MATCH_ERROR)
4297 0 : goto cleanup;
4298 7739 : if (m == MATCH_NO)
4299 4 : goto syntax;
4300 :
4301 7735 : comma_flag = 1;
4302 7735 : dt->io_unit = default_unit (k);
4303 7735 : goto get_io_list;
4304 : }
4305 : else
4306 : {
4307 : /* Before issuing an error for a malformed 'print (1,*)' type of
4308 : error, check for a default-char-expr of the form ('(I0)'). */
4309 25706 : if (m == MATCH_YES)
4310 : {
4311 25706 : control = gfc_current_locus;
4312 25706 : if (k == M_PRINT)
4313 : {
4314 : /* Reset current locus to get the initial '(' in an expression. */
4315 10 : gfc_current_locus = where;
4316 10 : dt->format_expr = NULL;
4317 10 : m = match_dt_format (dt);
4318 :
4319 10 : if (m == MATCH_ERROR)
4320 0 : goto cleanup;
4321 10 : if (m == MATCH_NO || dt->format_expr == NULL)
4322 3 : goto syntax;
4323 :
4324 7 : comma_flag = 1;
4325 7 : dt->io_unit = default_unit (k);
4326 7 : goto get_io_list;
4327 : }
4328 25696 : if (k == M_READ)
4329 : {
4330 : /* Commit any pending symbols now so that when we undo
4331 : symbols later we wont lose them. */
4332 6421 : gfc_commit_symbols ();
4333 : /* Reset current locus to get the initial '(' in an expression. */
4334 6421 : gfc_current_locus = where;
4335 6421 : dt->format_expr = NULL;
4336 6421 : m = gfc_match_expr (&dt->format_expr);
4337 6421 : if (m == MATCH_YES)
4338 : {
4339 545 : if (dt->format_expr
4340 545 : && dt->format_expr->ts.type == BT_CHARACTER)
4341 : {
4342 3 : comma_flag = 1;
4343 3 : dt->io_unit = default_unit (k);
4344 3 : goto get_io_list;
4345 : }
4346 : else
4347 : {
4348 542 : gfc_free_expr (dt->format_expr);
4349 542 : dt->format_expr = NULL;
4350 542 : gfc_current_locus = control;
4351 : }
4352 : }
4353 : else
4354 : {
4355 5876 : gfc_clear_error ();
4356 5876 : gfc_undo_symbols ();
4357 5876 : gfc_free_expr (dt->format_expr);
4358 5876 : dt->format_expr = NULL;
4359 5876 : gfc_current_locus = control;
4360 : }
4361 : }
4362 : }
4363 : }
4364 :
4365 : /* Match a control list */
4366 25693 : if (match_dt_element (k, dt) == MATCH_YES)
4367 1213 : goto next;
4368 24480 : if (match_dt_unit (k, dt) != MATCH_YES)
4369 0 : goto loop;
4370 :
4371 24480 : if (gfc_match_char (')') == MATCH_YES)
4372 1481 : goto get_io_list;
4373 22999 : if (gfc_match_char (',') != MATCH_YES)
4374 0 : goto syntax;
4375 :
4376 22999 : m = match_dt_element (k, dt);
4377 22999 : if (m == MATCH_YES)
4378 2660 : goto next;
4379 20339 : if (m == MATCH_ERROR)
4380 0 : goto cleanup;
4381 :
4382 20339 : m = match_dt_format (dt);
4383 20339 : if (m == MATCH_YES)
4384 19912 : goto next;
4385 427 : if (m == MATCH_ERROR)
4386 7 : goto cleanup;
4387 :
4388 420 : where = gfc_current_locus;
4389 :
4390 420 : m = gfc_match_name (name);
4391 420 : if (m == MATCH_YES)
4392 : {
4393 420 : gfc_find_symbol (name, NULL, 1, &sym);
4394 420 : if (sym && sym->attr.flavor == FL_NAMELIST)
4395 : {
4396 420 : dt->namelist = sym;
4397 420 : if (k == M_READ && check_namelist (sym))
4398 : {
4399 1 : m = MATCH_ERROR;
4400 1 : goto cleanup;
4401 : }
4402 419 : goto next;
4403 : }
4404 : }
4405 :
4406 0 : gfc_current_locus = where;
4407 :
4408 0 : goto loop; /* No matches, try regular elements */
4409 :
4410 24204 : next:
4411 24204 : if (gfc_match_char (')') == MATCH_YES)
4412 20016 : goto get_io_list;
4413 4188 : if (gfc_match_char (',') != MATCH_YES)
4414 0 : goto syntax;
4415 :
4416 4188 : loop:
4417 5296 : for (;;)
4418 : {
4419 5296 : m = match_dt_element (k, dt);
4420 5296 : if (m == MATCH_NO)
4421 0 : goto syntax;
4422 5296 : if (m == MATCH_ERROR)
4423 4 : goto cleanup;
4424 :
4425 5292 : if (gfc_match_char (')') == MATCH_YES)
4426 : break;
4427 1108 : if (gfc_match_char (',') != MATCH_YES)
4428 0 : goto syntax;
4429 : }
4430 :
4431 4184 : get_io_list:
4432 :
4433 : /* Save the IO kind for later use. */
4434 33435 : dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
4435 :
4436 : /* Optional leading comma (non-standard). We use a gfc_expr structure here
4437 : to save the locus. This is used later when resolving transfer statements
4438 : that might have a format expression without unit number. */
4439 33435 : if (!comma_flag && gfc_match_char (',') == MATCH_YES)
4440 87 : dt->extra_comma = dt->dt_io_kind;
4441 :
4442 33435 : io_code = NULL;
4443 33435 : if (gfc_match_eos () != MATCH_YES)
4444 : {
4445 31267 : if (comma_flag && gfc_match_char (',') != MATCH_YES)
4446 : {
4447 0 : gfc_error ("Expected comma in I/O list at %C");
4448 0 : m = MATCH_ERROR;
4449 0 : goto cleanup;
4450 : }
4451 :
4452 31267 : m = match_io_list (k, &io_code);
4453 31267 : if (m == MATCH_ERROR)
4454 113 : goto cleanup;
4455 : if (m == MATCH_NO)
4456 : goto syntax;
4457 : }
4458 :
4459 : /* See if we want to use defaults for missing exponents in real transfers
4460 : and other DEC runtime extensions. */
4461 33322 : if (flag_dec_format_defaults)
4462 484 : dt->dec_ext = 1;
4463 :
4464 : /* Check the format string now. */
4465 33322 : if (dt->format_expr
4466 33322 : && (!gfc_simplify_expr (dt->format_expr, 0)
4467 12287 : || !check_format_string (dt->format_expr, k == M_READ)))
4468 35 : return MATCH_ERROR;
4469 :
4470 33287 : new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
4471 33287 : new_st.ext.dt = dt;
4472 33287 : new_st.block = gfc_get_code (new_st.op);
4473 33287 : new_st.block->next = io_code;
4474 :
4475 33287 : terminate_io (io_code);
4476 :
4477 33287 : return MATCH_YES;
4478 :
4479 7 : syntax:
4480 7 : gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
4481 7 : m = MATCH_ERROR;
4482 :
4483 137 : cleanup:
4484 137 : gfc_free_dt (dt);
4485 137 : return m;
4486 : }
4487 :
4488 :
4489 : match
4490 6435 : gfc_match_read (void)
4491 : {
4492 6435 : return match_io (M_READ);
4493 : }
4494 :
4495 :
4496 : match
4497 19275 : gfc_match_write (void)
4498 : {
4499 19275 : return match_io (M_WRITE);
4500 : }
4501 :
4502 :
4503 : match
4504 7749 : gfc_match_print (void)
4505 : {
4506 7749 : match m;
4507 :
4508 7749 : m = match_io (M_PRINT);
4509 7749 : if (m != MATCH_YES)
4510 : return m;
4511 :
4512 7624 : if (gfc_pure (NULL))
4513 : {
4514 0 : gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4515 0 : return MATCH_ERROR;
4516 : }
4517 :
4518 7624 : gfc_unset_implicit_pure (NULL);
4519 :
4520 7624 : return MATCH_YES;
4521 : }
4522 :
4523 :
4524 : /* Free a gfc_inquire structure. */
4525 :
4526 : void
4527 846 : gfc_free_inquire (gfc_inquire *inquire)
4528 : {
4529 :
4530 846 : if (inquire == NULL)
4531 : return;
4532 :
4533 846 : gfc_free_expr (inquire->unit);
4534 846 : gfc_free_expr (inquire->file);
4535 846 : gfc_free_expr (inquire->iomsg);
4536 846 : gfc_free_expr (inquire->iostat);
4537 846 : gfc_free_expr (inquire->exist);
4538 846 : gfc_free_expr (inquire->opened);
4539 846 : gfc_free_expr (inquire->number);
4540 846 : gfc_free_expr (inquire->named);
4541 846 : gfc_free_expr (inquire->name);
4542 846 : gfc_free_expr (inquire->access);
4543 846 : gfc_free_expr (inquire->sequential);
4544 846 : gfc_free_expr (inquire->direct);
4545 846 : gfc_free_expr (inquire->form);
4546 846 : gfc_free_expr (inquire->formatted);
4547 846 : gfc_free_expr (inquire->unformatted);
4548 846 : gfc_free_expr (inquire->recl);
4549 846 : gfc_free_expr (inquire->nextrec);
4550 846 : gfc_free_expr (inquire->blank);
4551 846 : gfc_free_expr (inquire->position);
4552 846 : gfc_free_expr (inquire->action);
4553 846 : gfc_free_expr (inquire->read);
4554 846 : gfc_free_expr (inquire->write);
4555 846 : gfc_free_expr (inquire->readwrite);
4556 846 : gfc_free_expr (inquire->delim);
4557 846 : gfc_free_expr (inquire->encoding);
4558 846 : gfc_free_expr (inquire->pad);
4559 846 : gfc_free_expr (inquire->iolength);
4560 846 : gfc_free_expr (inquire->convert);
4561 846 : gfc_free_expr (inquire->strm_pos);
4562 846 : gfc_free_expr (inquire->asynchronous);
4563 846 : gfc_free_expr (inquire->decimal);
4564 846 : gfc_free_expr (inquire->pending);
4565 846 : gfc_free_expr (inquire->id);
4566 846 : gfc_free_expr (inquire->sign);
4567 846 : gfc_free_expr (inquire->size);
4568 846 : gfc_free_expr (inquire->round);
4569 846 : gfc_free_expr (inquire->share);
4570 846 : gfc_free_expr (inquire->cc);
4571 846 : free (inquire);
4572 : }
4573 :
4574 :
4575 : /* Match an element of an INQUIRE statement. */
4576 :
4577 : #define RETM if (m != MATCH_NO) return m;
4578 :
4579 : static match
4580 2607 : match_inquire_element (gfc_inquire *inquire)
4581 : {
4582 2607 : match m;
4583 :
4584 2607 : m = match_etag (&tag_unit, &inquire->unit);
4585 2607 : RETM m = match_etag (&tag_file, &inquire->file);
4586 2274 : RETM m = match_ltag (&tag_err, &inquire->err);
4587 2063 : RETM m = match_etag (&tag_iomsg, &inquire->iomsg);
4588 2056 : RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
4589 2031 : RETM m = match_vtag (&tag_exist, &inquire->exist);
4590 1982 : RETM m = match_vtag (&tag_opened, &inquire->opened);
4591 1840 : RETM m = match_vtag (&tag_named, &inquire->named);
4592 1688 : RETM m = match_vtag (&tag_name, &inquire->name);
4593 1665 : RETM m = match_out_tag (&tag_number, &inquire->number);
4594 1638 : RETM m = match_vtag (&tag_s_access, &inquire->access);
4595 1551 : RETM m = match_vtag (&tag_sequential, &inquire->sequential);
4596 1401 : RETM m = match_vtag (&tag_direct, &inquire->direct);
4597 1362 : RETM m = match_vtag (&tag_s_form, &inquire->form);
4598 1251 : RETM m = match_vtag (&tag_formatted, &inquire->formatted);
4599 1236 : RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
4600 1190 : RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
4601 1151 : RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
4602 1092 : RETM m = match_vtag (&tag_s_blank, &inquire->blank);
4603 1030 : RETM m = match_vtag (&tag_s_position, &inquire->position);
4604 1006 : RETM m = match_vtag (&tag_s_action, &inquire->action);
4605 949 : RETM m = match_vtag (&tag_read, &inquire->read);
4606 927 : RETM m = match_vtag (&tag_write, &inquire->write);
4607 894 : RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
4608 861 : RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
4609 828 : RETM m = match_vtag (&tag_s_delim, &inquire->delim);
4610 801 : RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
4611 761 : RETM m = match_out_tag (&tag_size, &inquire->size);
4612 742 : RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
4613 699 : RETM m = match_vtag (&tag_s_round, &inquire->round);
4614 679 : RETM m = match_vtag (&tag_s_sign, &inquire->sign);
4615 660 : RETM m = match_vtag (&tag_s_pad, &inquire->pad);
4616 641 : RETM m = match_out_tag (&tag_iolength, &inquire->iolength);
4617 602 : RETM m = match_vtag (&tag_convert, &inquire->convert);
4618 509 : RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
4619 497 : RETM m = match_vtag (&tag_pending, &inquire->pending);
4620 389 : RETM m = match_etag (&tag_id, &inquire->id);
4621 369 : RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
4622 358 : RETM m = match_dec_vtag (&tag_v_share, &inquire->share);
4623 316 : RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc);
4624 309 : RETM return MATCH_NO;
4625 : }
4626 :
4627 : #undef RETM
4628 :
4629 :
4630 : match
4631 938 : gfc_match_inquire (void)
4632 : {
4633 938 : gfc_inquire *inquire;
4634 938 : gfc_code *code;
4635 938 : match m;
4636 938 : locus loc;
4637 :
4638 938 : m = gfc_match_char ('(');
4639 938 : if (m == MATCH_NO)
4640 : return m;
4641 :
4642 938 : inquire = XCNEW (gfc_inquire);
4643 :
4644 938 : loc = gfc_current_locus;
4645 :
4646 938 : m = match_inquire_element (inquire);
4647 938 : if (m == MATCH_ERROR)
4648 0 : goto cleanup;
4649 938 : if (m == MATCH_NO)
4650 : {
4651 302 : m = gfc_match_expr (&inquire->unit);
4652 302 : if (m == MATCH_ERROR)
4653 0 : goto cleanup;
4654 302 : if (m == MATCH_NO)
4655 0 : goto syntax;
4656 : }
4657 :
4658 : /* See if we have the IOLENGTH form of the inquire statement. */
4659 938 : if (inquire->iolength != NULL)
4660 : {
4661 93 : if (gfc_match_char (')') != MATCH_YES)
4662 0 : goto syntax;
4663 :
4664 93 : m = match_io_list (M_INQUIRE, &code);
4665 93 : if (m == MATCH_ERROR)
4666 0 : goto cleanup;
4667 93 : if (m == MATCH_NO)
4668 : goto syntax;
4669 :
4670 246 : for (gfc_code *c = code; c; c = c->next)
4671 154 : if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION
4672 2 : && c->expr1->symtree && c->expr1->symtree->n.sym->attr.function
4673 2 : && !c->expr1->symtree->n.sym->attr.external
4674 1 : && strcmp (c->expr1->symtree->name, "null") == 0)
4675 : {
4676 1 : gfc_error ("NULL() near %L cannot appear in INQUIRE statement",
4677 : &c->expr1->where);
4678 1 : goto cleanup;
4679 : }
4680 :
4681 92 : new_st.op = EXEC_IOLENGTH;
4682 92 : new_st.expr1 = inquire->iolength;
4683 92 : new_st.ext.inquire = inquire;
4684 :
4685 92 : if (gfc_pure (NULL))
4686 : {
4687 0 : gfc_free_statements (code);
4688 0 : gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4689 0 : return MATCH_ERROR;
4690 : }
4691 :
4692 92 : gfc_unset_implicit_pure (NULL);
4693 :
4694 92 : new_st.block = gfc_get_code (EXEC_IOLENGTH);
4695 92 : terminate_io (code);
4696 92 : new_st.block->next = code;
4697 92 : return MATCH_YES;
4698 : }
4699 :
4700 : /* At this point, we have the non-IOLENGTH inquire statement. */
4701 2512 : for (;;)
4702 : {
4703 2512 : if (gfc_match_char (')') == MATCH_YES)
4704 : break;
4705 1669 : if (gfc_match_char (',') != MATCH_YES)
4706 0 : goto syntax;
4707 :
4708 1669 : m = match_inquire_element (inquire);
4709 1669 : if (m == MATCH_ERROR)
4710 2 : goto cleanup;
4711 1667 : if (m == MATCH_NO)
4712 0 : goto syntax;
4713 :
4714 1667 : if (inquire->iolength != NULL)
4715 : {
4716 0 : gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4717 0 : goto cleanup;
4718 : }
4719 : }
4720 :
4721 843 : if (gfc_match_eos () != MATCH_YES)
4722 0 : goto syntax;
4723 :
4724 843 : if (inquire->unit != NULL && inquire->file != NULL)
4725 : {
4726 2 : gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4727 : "UNIT specifiers", &loc);
4728 2 : goto cleanup;
4729 : }
4730 :
4731 841 : if (inquire->unit == NULL && inquire->file == NULL)
4732 : {
4733 1 : gfc_error ("INQUIRE statement at %L requires either FILE or "
4734 : "UNIT specifier", &loc);
4735 1 : goto cleanup;
4736 : }
4737 :
4738 840 : if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT
4739 524 : && inquire->unit->ts.type == BT_INTEGER
4740 524 : && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4)
4741 523 : || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT)))
4742 : {
4743 2 : gfc_error ("UNIT number in INQUIRE statement at %L cannot "
4744 : "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer));
4745 2 : goto cleanup;
4746 : }
4747 :
4748 838 : if (gfc_pure (NULL))
4749 : {
4750 0 : gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4751 0 : goto cleanup;
4752 : }
4753 :
4754 838 : gfc_unset_implicit_pure (NULL);
4755 :
4756 838 : if (inquire->id != NULL && inquire->pending == NULL)
4757 : {
4758 0 : gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4759 : "the ID= specifier", &loc);
4760 0 : goto cleanup;
4761 : }
4762 :
4763 838 : new_st.op = EXEC_INQUIRE;
4764 838 : new_st.ext.inquire = inquire;
4765 838 : return MATCH_YES;
4766 :
4767 0 : syntax:
4768 0 : gfc_syntax_error (ST_INQUIRE);
4769 :
4770 8 : cleanup:
4771 8 : gfc_free_inquire (inquire);
4772 8 : return MATCH_ERROR;
4773 : }
4774 :
4775 :
4776 : /* Resolve everything in a gfc_inquire structure. */
4777 :
4778 : bool
4779 930 : gfc_resolve_inquire (gfc_inquire *inquire)
4780 : {
4781 930 : RESOLVE_TAG (&tag_unit, inquire->unit);
4782 930 : RESOLVE_TAG (&tag_file, inquire->file);
4783 929 : RESOLVE_TAG (&tag_id, inquire->id);
4784 :
4785 : /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4786 : contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4787 : #define INQUIRE_RESOLVE_TAG(tag, expr) \
4788 : RESOLVE_TAG (tag, expr); \
4789 : if (expr) \
4790 : { \
4791 : char context[64]; \
4792 : sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4793 : if (gfc_check_vardef_context ((expr), false, false, false, \
4794 : context) == false) \
4795 : return false; \
4796 : gfc_expr_set_at (expr, &expr->where, VALUE_VARDEF); \
4797 : }
4798 929 : INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4799 917 : INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4800 916 : INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4801 914 : INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4802 912 : INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4803 910 : INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4804 908 : INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4805 907 : INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4806 906 : INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4807 905 : INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4808 904 : INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4809 903 : INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4810 901 : INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4811 900 : INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4812 899 : INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4813 898 : INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4814 897 : INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4815 896 : INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4816 895 : INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4817 894 : INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4818 893 : INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4819 892 : INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4820 891 : INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4821 890 : INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4822 888 : INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4823 887 : INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4824 885 : INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4825 885 : INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4826 885 : INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4827 884 : INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4828 883 : INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4829 883 : INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4830 881 : INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4831 881 : INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4832 880 : INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
4833 880 : INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share);
4834 880 : INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc);
4835 : #undef INQUIRE_RESOLVE_TAG
4836 :
4837 880 : if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4838 : return false;
4839 :
4840 : return true;
4841 : }
4842 :
4843 :
4844 : void
4845 89 : gfc_free_wait (gfc_wait *wait)
4846 : {
4847 89 : if (wait == NULL)
4848 : return;
4849 :
4850 89 : gfc_free_expr (wait->unit);
4851 89 : gfc_free_expr (wait->iostat);
4852 89 : gfc_free_expr (wait->iomsg);
4853 89 : gfc_free_expr (wait->id);
4854 89 : free (wait);
4855 : }
4856 :
4857 :
4858 : bool
4859 89 : gfc_resolve_wait (gfc_wait *wait)
4860 : {
4861 89 : RESOLVE_TAG (&tag_unit, wait->unit);
4862 89 : RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4863 74 : RESOLVE_TAG (&tag_iostat, wait->iostat);
4864 74 : RESOLVE_TAG (&tag_id, wait->id);
4865 :
4866 74 : if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4867 : return false;
4868 :
4869 74 : if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4870 : return false;
4871 :
4872 : return true;
4873 : }
4874 :
4875 : /* Match an element of a WAIT statement. */
4876 :
4877 : #define RETM if (m != MATCH_NO) return m;
4878 :
4879 : static match
4880 166 : match_wait_element (gfc_wait *wait)
4881 : {
4882 166 : match m;
4883 :
4884 166 : m = match_etag (&tag_unit, &wait->unit);
4885 166 : RETM m = match_ltag (&tag_err, &wait->err);
4886 153 : RETM m = match_ltag (&tag_end, &wait->end);
4887 146 : RETM m = match_ltag (&tag_eor, &wait->eor);
4888 139 : RETM m = match_etag (&tag_iomsg, &wait->iomsg);
4889 139 : RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4890 110 : RETM m = match_etag (&tag_id, &wait->id);
4891 89 : RETM return MATCH_NO;
4892 : }
4893 :
4894 : #undef RETM
4895 :
4896 :
4897 : match
4898 89 : gfc_match_wait (void)
4899 : {
4900 89 : gfc_wait *wait;
4901 89 : match m;
4902 :
4903 89 : m = gfc_match_char ('(');
4904 89 : if (m == MATCH_NO)
4905 : return m;
4906 :
4907 89 : wait = XCNEW (gfc_wait);
4908 :
4909 89 : m = match_wait_element (wait);
4910 89 : if (m == MATCH_ERROR)
4911 0 : goto cleanup;
4912 89 : if (m == MATCH_NO)
4913 : {
4914 76 : m = gfc_match_expr (&wait->unit);
4915 76 : if (m == MATCH_ERROR)
4916 0 : goto cleanup;
4917 76 : if (m == MATCH_NO)
4918 0 : goto syntax;
4919 : }
4920 :
4921 166 : for (;;)
4922 : {
4923 166 : if (gfc_match_char (')') == MATCH_YES)
4924 : break;
4925 77 : if (gfc_match_char (',') != MATCH_YES)
4926 0 : goto syntax;
4927 :
4928 77 : m = match_wait_element (wait);
4929 77 : if (m == MATCH_ERROR)
4930 0 : goto cleanup;
4931 77 : if (m == MATCH_NO)
4932 0 : goto syntax;
4933 : }
4934 :
4935 89 : if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4936 : "not allowed in Fortran 95"))
4937 0 : goto cleanup;
4938 :
4939 89 : if (gfc_pure (NULL))
4940 : {
4941 0 : gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4942 0 : goto cleanup;
4943 : }
4944 :
4945 89 : gfc_unset_implicit_pure (NULL);
4946 :
4947 89 : new_st.op = EXEC_WAIT;
4948 89 : new_st.ext.wait = wait;
4949 :
4950 89 : return MATCH_YES;
4951 :
4952 0 : syntax:
4953 0 : gfc_syntax_error (ST_WAIT);
4954 :
4955 0 : cleanup:
4956 0 : gfc_free_wait (wait);
4957 0 : return MATCH_ERROR;
4958 : }
|
