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 163850 : next_char (gfc_instring in_string)
148 : {
149 163850 : static gfc_char_t c;
150 :
151 163850 : if (use_last_char)
152 : {
153 28017 : use_last_char = 0;
154 28017 : return c;
155 : }
156 :
157 135833 : format_length++;
158 :
159 135833 : if (mode == MODE_STRING)
160 78415 : 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 135833 : 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 135833 : if (mode == MODE_COPY)
180 28649 : *format_string++ = c;
181 :
182 135833 : if (mode != MODE_STRING)
183 57418 : format_locus = gfc_current_locus;
184 :
185 135833 : format_string_pos++;
186 :
187 135833 : c = gfc_wide_toupper (c);
188 135833 : return c;
189 : }
190 :
191 :
192 : /* Back up one character position. Only works once. */
193 :
194 : static void
195 28023 : unget_char (void)
196 : {
197 28023 : use_last_char = 1;
198 2616 : }
199 :
200 : /* Eat up the spaces and return a character. */
201 :
202 : static char
203 124703 : next_char_not_space ()
204 : {
205 133258 : char c;
206 133258 : do
207 : {
208 133258 : error_element = c = next_char (NONSTRING);
209 133258 : if (c == '\t')
210 4 : gfc_warning (OPT_Wtabs, "Nonconforming tab character in format at %C");
211 : }
212 133258 : while (gfc_is_whitespace (c));
213 124703 : 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 119710 : format_lex (void)
223 : {
224 119710 : format_token token;
225 119710 : char c, delim;
226 119710 : int zflag;
227 119710 : int negative_flag;
228 :
229 119710 : if (saved_token != FMT_NONE)
230 : {
231 27351 : token = saved_token;
232 27351 : saved_token = FMT_NONE;
233 27351 : return token;
234 : }
235 :
236 92359 : c = next_char_not_space ();
237 :
238 92359 : negative_flag = 0;
239 92359 : 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 22999 : case '0':
272 22999 : case '1':
273 22999 : case '2':
274 22999 : case '3':
275 22999 : case '4':
276 22999 : case '5':
277 22999 : case '6':
278 22999 : case '7':
279 22999 : case '8':
280 22999 : case '9':
281 22999 : zflag = (c == '0');
282 :
283 22999 : value = c - '0';
284 :
285 27791 : do
286 : {
287 27791 : c = next_char_not_space ();
288 27791 : if (ISDIGIT (c))
289 : {
290 4792 : value = 10 * value + (c - '0');
291 4792 : if (c != '0')
292 27791 : zflag = 0;
293 : }
294 : }
295 27791 : while (ISDIGIT (c));
296 :
297 22999 : unget_char ();
298 22999 : token = zflag ? FMT_ZERO : FMT_POSINT;
299 : break;
300 :
301 : case '.':
302 : token = FMT_PERIOD;
303 : break;
304 :
305 10883 : case ',':
306 10883 : token = FMT_COMMA;
307 10883 : 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 14147 : case '(':
338 14147 : token = FMT_LPAREN;
339 14147 : break;
340 :
341 14117 : case ')':
342 14117 : token = FMT_RPAREN;
343 14117 : 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 4789 : token = FMT_IBOZ;
413 : break;
414 :
415 1903 : case 'F':
416 1903 : token = FMT_F;
417 1903 : break;
418 :
419 2040 : case 'E':
420 2040 : c = next_char_not_space ();
421 2040 : 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 7908 : case 'A':
479 7908 : token = FMT_A;
480 7908 : 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 13055 : check_format (bool is_input)
627 : {
628 13055 : const char *posint_required
629 : = G_("Positive width required in format string at %L");
630 13055 : const char *nonneg_required
631 : = G_("Nonnegative width required in format string at %L");
632 13055 : const char *unexpected_element
633 : = G_("Unexpected element %qc in format string at %L");
634 13055 : const char *unexpected_end
635 : = G_("Unexpected end of format string in format string at %L");
636 13055 : const char *zero_width
637 : = G_("Zero width in format descriptor in format string at %L");
638 :
639 13055 : const char *error = NULL;
640 13055 : format_token t, u;
641 13055 : int level;
642 13055 : int repeat;
643 13055 : bool rv;
644 :
645 13055 : use_last_char = 0;
646 13055 : saved_token = FMT_NONE;
647 13055 : level = 0;
648 13055 : repeat = 0;
649 13055 : rv = true;
650 13055 : format_string_pos = 0;
651 :
652 13055 : t = format_lex ();
653 13055 : if (t == FMT_ERROR)
654 0 : goto fail;
655 13055 : 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 13049 : t = format_lex ();
662 13049 : if (t == FMT_ERROR)
663 0 : goto fail;
664 13049 : if (t == FMT_RPAREN)
665 52 : goto finished; /* Empty format is legal */
666 12997 : saved_token = t;
667 :
668 25779 : format_item:
669 : /* In this state, the next thing has to be a format item. */
670 25779 : t = format_lex ();
671 25779 : if (t == FMT_ERROR)
672 0 : goto fail;
673 25779 : format_item_1:
674 25820 : 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 16073 : case FMT_T:
775 16073 : case FMT_TL:
776 16073 : case FMT_TR:
777 16073 : case FMT_IBOZ:
778 16073 : case FMT_F:
779 16073 : case FMT_E:
780 16073 : case FMT_EN:
781 16073 : case FMT_ES:
782 16073 : case FMT_EX:
783 16073 : case FMT_G:
784 16073 : case FMT_L:
785 16073 : case FMT_A:
786 16073 : case FMT_D:
787 16073 : case FMT_H:
788 16073 : case FMT_DT:
789 16073 : 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 21234 : data_desc:
810 : /* In this state, t must currently be a data descriptor.
811 : Deal with things that can/must follow the descriptor. */
812 21234 : 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 7902 : case FMT_A:
902 7902 : t = format_lex ();
903 7902 : if (t == FMT_ERROR)
904 0 : goto fail;
905 7902 : if (t == FMT_ZERO)
906 : {
907 0 : error = zero_width;
908 0 : goto syntax;
909 : }
910 7902 : if (t != FMT_POSINT)
911 6329 : saved_token = t;
912 : break;
913 :
914 2707 : case FMT_D:
915 2707 : case FMT_E:
916 2707 : case FMT_EX:
917 2707 : case FMT_G:
918 2707 : case FMT_EN:
919 2707 : case FMT_ES:
920 2707 : u = format_lex ();
921 2707 : 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 2304 : if (u != FMT_POSINT)
955 : {
956 714 : 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 679 : format_locus.nextc += format_string_pos;
975 679 : 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 678 : 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 2238 : u = format_lex ();
991 2238 : if (u == FMT_ERROR)
992 0 : goto fail;
993 2238 : 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 2224 : u = format_lex ();
1017 2224 : if (u == FMT_ERROR)
1018 0 : goto fail;
1019 2224 : if (u != FMT_ZERO && u != FMT_POSINT)
1020 : {
1021 0 : error = nonneg_required;
1022 0 : goto syntax;
1023 : }
1024 :
1025 2224 : if (t == FMT_D)
1026 : break;
1027 :
1028 : /* Look for optional exponent. */
1029 2098 : u = format_lex ();
1030 2098 : if (u == FMT_ERROR)
1031 0 : goto fail;
1032 2098 : if (u != FMT_E)
1033 1600 : 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 4789 : case FMT_IBOZ:
1194 4789 : t = format_lex ();
1195 4789 : if (t == FMT_ERROR)
1196 0 : goto fail;
1197 4789 : 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 4722 : else if (is_input && t == FMT_ZERO)
1212 : {
1213 2 : error = posint_required;
1214 2 : goto syntax;
1215 : }
1216 :
1217 4780 : t = format_lex ();
1218 4780 : if (t == FMT_ERROR)
1219 0 : goto fail;
1220 4780 : if (t != FMT_PERIOD)
1221 4342 : saved_token = t;
1222 : else
1223 : {
1224 438 : t = format_lex ();
1225 438 : if (t == FMT_ERROR)
1226 0 : goto fail;
1227 438 : 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 22030 : t = format_lex ();
1244 22030 : if (t == FMT_ERROR)
1245 0 : goto fail;
1246 22030 : switch (t)
1247 : {
1248 :
1249 9257 : case FMT_COMMA:
1250 9257 : goto format_item;
1251 :
1252 12486 : case FMT_RPAREN:
1253 12486 : level--;
1254 12486 : if (level < 0)
1255 11678 : 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 12087 : check_format_string (gfc_expr *e, bool is_input)
1365 : {
1366 12087 : bool rv;
1367 12087 : int i;
1368 12087 : if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1369 : return true;
1370 :
1371 11016 : mode = MODE_STRING;
1372 11016 : 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 11016 : format_locus = e->where;
1378 11016 : 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 11016 : 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 667083 : match_etag (const io_tag *tag, gfc_expr **v)
1470 : {
1471 667083 : gfc_expr *result;
1472 667083 : match m;
1473 :
1474 667083 : m = gfc_match (tag->spec);
1475 667083 : if (m != MATCH_YES)
1476 : return m;
1477 :
1478 12789 : m = gfc_match (tag->value, &result);
1479 12789 : 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 12789 : 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 12787 : *v = result;
1493 12787 : return MATCH_YES;
1494 : }
1495 :
1496 :
1497 : /* Match a variable I/O tag of some sort. */
1498 :
1499 : static match
1500 195269 : match_vtag (const io_tag *tag, gfc_expr **v)
1501 : {
1502 195269 : gfc_expr *result;
1503 195269 : match m;
1504 :
1505 195269 : m = gfc_match (tag->spec);
1506 195269 : if (m != MATCH_YES)
1507 : return m;
1508 :
1509 4042 : m = gfc_match (tag->value, &result);
1510 4042 : 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 4041 : 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 4041 : if (result->symtree)
1524 : {
1525 4037 : bool impure;
1526 :
1527 4037 : 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 4037 : impure = gfc_impure_variable (result->symtree->n.sym);
1535 4037 : 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 4037 : if (impure)
1544 28 : gfc_unset_implicit_pure (NULL);
1545 : }
1546 :
1547 4041 : *v = result;
1548 4041 : return MATCH_YES;
1549 : }
1550 :
1551 :
1552 : /* Match I/O tags that cause variables to become redefined. */
1553 :
1554 : static match
1555 167542 : match_out_tag (const io_tag *tag, gfc_expr **result)
1556 : {
1557 167542 : match m;
1558 :
1559 167542 : m = match_vtag (tag, result);
1560 167542 : if (m == MATCH_YES)
1561 : {
1562 2824 : if ((*result)->symtree)
1563 2820 : gfc_check_do_variable ((*result)->symtree);
1564 :
1565 2824 : 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 146027 : match_ltag (const io_tag *tag, gfc_st_label ** label)
1580 : {
1581 146027 : match m;
1582 146027 : gfc_st_label *old;
1583 :
1584 146027 : old = *label;
1585 146027 : m = gfc_match (tag->spec);
1586 146027 : 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 621 : match_dec_vtag (const io_tag *tag, gfc_expr **e)
1629 : {
1630 621 : match m = match_vtag(tag, e);
1631 621 : if (flag_dec && m != MATCH_NO)
1632 : return m;
1633 603 : 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 12048 : resolve_tag_format (gfc_expr *e)
1704 : {
1705 12048 : if (e->expr_type == EXPR_CONSTANT
1706 10985 : && (e->ts.type != BT_CHARACTER
1707 10981 : || 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 12022 : if ((e->expr_type == EXPR_ARRAY || e->rank > 0)
1718 111 : && e->ts.type == BT_CHARACTER
1719 12117 : && 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 12042 : if (e->rank == 0
1766 11933 : && (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 11854 : if ((e->ts.type != BT_CHARACTER
1772 11845 : || 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 11849 : 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 11846 : 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 11845 : return true;
1799 : }
1800 :
1801 : /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1802 : It may be assigned an Hollerith constant. */
1803 188 : if (e->ts.type != BT_CHARACTER)
1804 : {
1805 : if (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS
1806 : || e->ts.type == BT_VOID || e->ts.type == BT_UNKNOWN)
1807 : {
1808 5 : gfc_error ("Non-character non-Hollerith in FORMAT tag at %L",
1809 : &e->where);
1810 5 : return false;
1811 : }
1812 62 : if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
1813 : "at %L", &e->where))
1814 : return false;
1815 :
1816 60 : if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1817 : {
1818 1 : gfc_error ("Non-character assumed shape array element in FORMAT"
1819 : " tag at %L", &e->where);
1820 1 : return false;
1821 : }
1822 :
1823 59 : if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1824 : {
1825 1 : gfc_error ("Non-character assumed size array element in FORMAT"
1826 : " tag at %L", &e->where);
1827 1 : return false;
1828 : }
1829 :
1830 58 : if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1831 : {
1832 1 : gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1833 : &e->where);
1834 1 : return false;
1835 : }
1836 : }
1837 :
1838 : return true;
1839 : }
1840 :
1841 :
1842 : /* Do expression resolution and type-checking on an expression tag. */
1843 :
1844 : static bool
1845 634829 : resolve_tag (const io_tag *tag, gfc_expr *e)
1846 : {
1847 634829 : if (e == NULL)
1848 : return true;
1849 :
1850 37600 : if (!gfc_resolve_expr (e))
1851 : return false;
1852 :
1853 37596 : if (tag == &tag_format)
1854 12048 : return resolve_tag_format (e);
1855 :
1856 25548 : if (e->ts.type != tag->type)
1857 : {
1858 348 : gfc_error ("%s tag at %L must be of type %s", tag->name,
1859 : &e->where, gfc_basic_typename (tag->type));
1860 348 : return false;
1861 : }
1862 :
1863 25200 : if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
1864 : {
1865 68 : gfc_error ("%s tag at %L must be a character string of default kind",
1866 68 : tag->name, &e->where);
1867 68 : return false;
1868 : }
1869 :
1870 25132 : if (e->rank != 0)
1871 : {
1872 52 : gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1873 52 : return false;
1874 : }
1875 :
1876 25080 : if (tag == &tag_iomsg)
1877 : {
1878 565 : if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where))
1879 : return false;
1880 : }
1881 :
1882 25080 : if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength
1883 22751 : || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl)
1884 2537 : && e->ts.kind != gfc_default_integer_kind)
1885 : {
1886 105 : if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1887 105 : "INTEGER in %s tag at %L", tag->name, &e->where))
1888 : return false;
1889 : }
1890 :
1891 25064 : if (e->ts.kind != gfc_default_logical_kind &&
1892 10979 : (tag == &tag_exist || tag == &tag_named || tag == &tag_opened
1893 10973 : || tag == &tag_pending))
1894 : {
1895 39 : if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind "
1896 39 : "in %s tag at %L", tag->name, &e->where))
1897 : return false;
1898 : }
1899 :
1900 25056 : if (tag == &tag_newunit)
1901 : {
1902 145 : if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L",
1903 : &e->where))
1904 : return false;
1905 : }
1906 :
1907 : /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1908 25055 : if (tag == &tag_newunit || tag == &tag_iostat
1909 22789 : || tag == &tag_size || tag == &tag_iomsg)
1910 : {
1911 2935 : char context[64];
1912 :
1913 2935 : sprintf (context, _("%s tag"), tag->name);
1914 2935 : if (!gfc_check_vardef_context (e, false, false, false, context))
1915 32 : return false;
1916 : }
1917 :
1918 25023 : if (tag == &tag_convert)
1919 : {
1920 84 : if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where))
1921 : return false;
1922 : }
1923 :
1924 : return true;
1925 : }
1926 :
1927 :
1928 : /* Match a single tag of an OPEN statement. */
1929 :
1930 : static match
1931 11142 : match_open_element (gfc_open *open)
1932 : {
1933 11142 : match m;
1934 :
1935 11142 : m = match_etag (&tag_e_async, &open->asynchronous);
1936 11142 : if (m != MATCH_NO)
1937 : return m;
1938 11026 : m = match_etag (&tag_unit, &open->unit);
1939 11026 : if (m != MATCH_NO)
1940 : return m;
1941 10084 : m = match_etag (&tag_iomsg, &open->iomsg);
1942 10084 : if (m != MATCH_NO)
1943 : return m;
1944 10026 : m = match_out_tag (&tag_iostat, &open->iostat);
1945 10026 : if (m != MATCH_NO)
1946 : return m;
1947 9851 : m = match_etag (&tag_file, &open->file);
1948 9851 : if (m != MATCH_NO)
1949 : return m;
1950 8346 : m = match_etag (&tag_status, &open->status);
1951 8346 : if (m != MATCH_NO)
1952 : return m;
1953 6200 : m = match_etag (&tag_e_access, &open->access);
1954 6200 : if (m != MATCH_NO)
1955 : return m;
1956 5419 : m = match_etag (&tag_e_form, &open->form);
1957 5419 : if (m != MATCH_NO)
1958 : return m;
1959 4320 : m = match_etag (&tag_e_recl, &open->recl);
1960 4320 : if (m != MATCH_NO)
1961 : return m;
1962 4066 : m = match_etag (&tag_e_blank, &open->blank);
1963 4066 : if (m != MATCH_NO)
1964 : return m;
1965 4027 : m = match_etag (&tag_e_position, &open->position);
1966 4027 : if (m != MATCH_NO)
1967 : return m;
1968 3891 : m = match_etag (&tag_e_action, &open->action);
1969 3891 : if (m != MATCH_NO)
1970 : return m;
1971 3629 : m = match_etag (&tag_e_delim, &open->delim);
1972 3629 : if (m != MATCH_NO)
1973 : return m;
1974 3486 : m = match_etag (&tag_e_pad, &open->pad);
1975 3486 : if (m != MATCH_NO)
1976 : return m;
1977 3431 : m = match_etag (&tag_e_decimal, &open->decimal);
1978 3431 : if (m != MATCH_NO)
1979 : return m;
1980 3381 : m = match_etag (&tag_e_encoding, &open->encoding);
1981 3381 : if (m != MATCH_NO)
1982 : return m;
1983 3307 : m = match_etag (&tag_e_round, &open->round);
1984 3307 : if (m != MATCH_NO)
1985 : return m;
1986 3293 : m = match_etag (&tag_e_sign, &open->sign);
1987 3293 : if (m != MATCH_NO)
1988 : return m;
1989 3261 : m = match_ltag (&tag_err, &open->err);
1990 3261 : if (m != MATCH_NO)
1991 : return m;
1992 3145 : m = match_etag (&tag_convert, &open->convert);
1993 3145 : if (m != MATCH_NO)
1994 : return m;
1995 3073 : m = match_out_tag (&tag_newunit, &open->newunit);
1996 3073 : if (m != MATCH_NO)
1997 : return m;
1998 :
1999 : /* The following are extensions enabled with -fdec. */
2000 2925 : m = match_dec_etag (&tag_e_share, &open->share);
2001 2925 : if (m != MATCH_NO)
2002 : return m;
2003 2907 : m = match_dec_etag (&tag_cc, &open->cc);
2004 2907 : if (m != MATCH_NO)
2005 : return m;
2006 2876 : m = match_dec_ftag (&tag_readonly, open);
2007 2876 : if (m != MATCH_NO)
2008 : return m;
2009 2852 : m = match_dec_ftag (&tag_shared, open);
2010 2852 : if (m != MATCH_NO)
2011 : return m;
2012 2841 : m = match_dec_ftag (&tag_noshared, open);
2013 2841 : if (m != MATCH_NO)
2014 : return m;
2015 :
2016 : return MATCH_NO;
2017 : }
2018 :
2019 :
2020 : /* Free the gfc_open structure and all the expressions it contains. */
2021 :
2022 : void
2023 3923 : gfc_free_open (gfc_open *open)
2024 : {
2025 3923 : if (open == NULL)
2026 : return;
2027 :
2028 3923 : gfc_free_expr (open->unit);
2029 3923 : gfc_free_expr (open->iomsg);
2030 3923 : gfc_free_expr (open->iostat);
2031 3923 : gfc_free_expr (open->file);
2032 3923 : gfc_free_expr (open->status);
2033 3923 : gfc_free_expr (open->access);
2034 3923 : gfc_free_expr (open->form);
2035 3923 : gfc_free_expr (open->recl);
2036 3923 : gfc_free_expr (open->blank);
2037 3923 : gfc_free_expr (open->position);
2038 3923 : gfc_free_expr (open->action);
2039 3923 : gfc_free_expr (open->delim);
2040 3923 : gfc_free_expr (open->pad);
2041 3923 : gfc_free_expr (open->decimal);
2042 3923 : gfc_free_expr (open->encoding);
2043 3923 : gfc_free_expr (open->round);
2044 3923 : gfc_free_expr (open->sign);
2045 3923 : gfc_free_expr (open->convert);
2046 3923 : gfc_free_expr (open->asynchronous);
2047 3923 : gfc_free_expr (open->newunit);
2048 3923 : gfc_free_expr (open->share);
2049 3923 : gfc_free_expr (open->cc);
2050 3923 : free (open);
2051 : }
2052 :
2053 : static bool
2054 : check_open_constraints (gfc_open *open, locus *where);
2055 :
2056 : /* Resolve everything in a gfc_open structure. */
2057 :
2058 : bool
2059 3906 : gfc_resolve_open (gfc_open *open, locus *where)
2060 : {
2061 3906 : RESOLVE_TAG (&tag_unit, open->unit);
2062 3906 : RESOLVE_TAG (&tag_iomsg, open->iomsg);
2063 3890 : RESOLVE_TAG (&tag_iostat, open->iostat);
2064 3889 : RESOLVE_TAG (&tag_file, open->file);
2065 3888 : RESOLVE_TAG (&tag_status, open->status);
2066 3874 : RESOLVE_TAG (&tag_e_access, open->access);
2067 3862 : RESOLVE_TAG (&tag_e_form, open->form);
2068 3851 : RESOLVE_TAG (&tag_e_recl, open->recl);
2069 3845 : RESOLVE_TAG (&tag_e_blank, open->blank);
2070 3833 : RESOLVE_TAG (&tag_e_position, open->position);
2071 3822 : RESOLVE_TAG (&tag_e_action, open->action);
2072 3811 : RESOLVE_TAG (&tag_e_delim, open->delim);
2073 3800 : RESOLVE_TAG (&tag_e_pad, open->pad);
2074 3789 : RESOLVE_TAG (&tag_e_decimal, open->decimal);
2075 3777 : RESOLVE_TAG (&tag_e_encoding, open->encoding);
2076 3765 : RESOLVE_TAG (&tag_e_async, open->asynchronous);
2077 3754 : RESOLVE_TAG (&tag_e_round, open->round);
2078 3742 : RESOLVE_TAG (&tag_e_sign, open->sign);
2079 3730 : RESOLVE_TAG (&tag_convert, open->convert);
2080 3730 : RESOLVE_TAG (&tag_newunit, open->newunit);
2081 3728 : RESOLVE_TAG (&tag_e_share, open->share);
2082 3727 : RESOLVE_TAG (&tag_cc, open->cc);
2083 :
2084 3726 : if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
2085 : return false;
2086 :
2087 3726 : return check_open_constraints (open, where);
2088 : }
2089 :
2090 :
2091 : /* Check if a given value for a SPECIFIER is either in the list of values
2092 : allowed in F95 or F2003, issuing an error message and returning a zero
2093 : value if it is not allowed. */
2094 :
2095 :
2096 : static bool
2097 6943 : compare_to_allowed_values (const char *specifier, const char *allowed[],
2098 : const char *allowed_f2003[],
2099 : const char *allowed_gnu[], gfc_char_t *value,
2100 : const char *statement, bool warn, locus *where,
2101 : int *num = NULL)
2102 : {
2103 6943 : int i;
2104 6943 : unsigned int len;
2105 :
2106 6943 : len = gfc_wide_strlen (value);
2107 6943 : if (len > 0)
2108 : {
2109 6930 : for (len--; len > 0; len--)
2110 6930 : if (value[len] != ' ')
2111 : break;
2112 6912 : len++;
2113 : }
2114 :
2115 15548 : for (i = 0; allowed[i]; i++)
2116 15015 : if (len == strlen (allowed[i])
2117 15015 : && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
2118 : {
2119 6410 : if (num)
2120 199 : *num = i;
2121 6410 : return 1;
2122 : }
2123 :
2124 533 : if (!where)
2125 0 : where = &gfc_current_locus;
2126 :
2127 562 : for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
2128 443 : if (len == strlen (allowed_f2003[i])
2129 443 : && gfc_wide_strncasecmp (value, allowed_f2003[i],
2130 : strlen (allowed_f2003[i])) == 0)
2131 : {
2132 414 : notification n = gfc_notification_std (GFC_STD_F2003);
2133 :
2134 414 : if (n == WARNING || (warn && n == ERROR))
2135 : {
2136 0 : gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L "
2137 : "has value %qs", specifier, statement, where,
2138 : allowed_f2003[i]);
2139 0 : return 1;
2140 : }
2141 : else
2142 414 : if (n == ERROR)
2143 : {
2144 0 : gfc_notify_std (GFC_STD_F2003, "%s specifier in "
2145 : "%s statement at %L has value %qs", specifier,
2146 : statement, where, allowed_f2003[i]);
2147 0 : return 0;
2148 : }
2149 :
2150 : /* n == SILENT */
2151 : return 1;
2152 : }
2153 :
2154 127 : for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
2155 29 : if (len == strlen (allowed_gnu[i])
2156 29 : && gfc_wide_strncasecmp (value, allowed_gnu[i],
2157 : strlen (allowed_gnu[i])) == 0)
2158 : {
2159 21 : notification n = gfc_notification_std (GFC_STD_GNU);
2160 :
2161 21 : if (n == WARNING || (warn && n == ERROR))
2162 : {
2163 21 : gfc_warning (0, "Extension: %s specifier in %s statement at %L "
2164 : "has value %qs", specifier, statement, where,
2165 : allowed_gnu[i]);
2166 21 : return 1;
2167 : }
2168 : else
2169 0 : if (n == ERROR)
2170 : {
2171 0 : gfc_notify_std (GFC_STD_GNU, "%s specifier in "
2172 : "%s statement at %L has value %qs", specifier,
2173 : statement, where, allowed_gnu[i]);
2174 0 : return 0;
2175 : }
2176 :
2177 : /* n == SILENT */
2178 : return 1;
2179 : }
2180 :
2181 98 : if (warn)
2182 : {
2183 38 : char *s = gfc_widechar_to_char (value, -1);
2184 38 : gfc_warning (0,
2185 : "%s specifier in %s statement at %L has invalid value %qs",
2186 : specifier, statement, where, s);
2187 38 : free (s);
2188 38 : return 1;
2189 : }
2190 : else
2191 : {
2192 60 : char *s = gfc_widechar_to_char (value, -1);
2193 60 : gfc_error ("%s specifier in %s statement at %L has invalid value %qs",
2194 : specifier, statement, where, s);
2195 60 : free (s);
2196 60 : return 0;
2197 : }
2198 : }
2199 :
2200 :
2201 : /* Check constraints on the OPEN statement.
2202 : Similar to check_io_constraints for data transfer statements.
2203 : At this point all tags have already been resolved via resolve_tag, which,
2204 : among other things, verifies that BT_CHARACTER tags are of default kind. */
2205 :
2206 : static bool
2207 3726 : check_open_constraints (gfc_open *open, locus *where)
2208 : {
2209 : #define warn_or_error(...) \
2210 : { \
2211 : if (warn) \
2212 : gfc_warning (0, __VA_ARGS__); \
2213 : else \
2214 : { \
2215 : gfc_error (__VA_ARGS__); \
2216 : return false; \
2217 : } \
2218 : }
2219 :
2220 3726 : bool warn = (open->err || open->iostat) ? true : false;
2221 :
2222 : /* Checks on the ACCESS specifier. */
2223 3726 : if (open->access && open->access->expr_type == EXPR_CONSTANT)
2224 : {
2225 769 : static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
2226 769 : static const char *access_f2003[] = { "STREAM", NULL };
2227 769 : static const char *access_gnu[] = { "APPEND", NULL };
2228 :
2229 769 : if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
2230 : access_gnu,
2231 : open->access->value.character.string,
2232 : "OPEN", warn, &open->access->where))
2233 : return false;
2234 : }
2235 :
2236 : /* Checks on the ACTION specifier. */
2237 3722 : if (open->action && open->action->expr_type == EXPR_CONSTANT)
2238 : {
2239 238 : gfc_char_t *str = open->action->value.character.string;
2240 238 : static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
2241 :
2242 238 : if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
2243 : str, "OPEN", warn, &open->action->where))
2244 : return false;
2245 :
2246 : /* With READONLY, only allow ACTION='READ'. */
2247 235 : if (open->readonly && (gfc_wide_strlen (str) != 4
2248 8 : || gfc_wide_strncasecmp (str, "READ", 4) != 0))
2249 : {
2250 2 : gfc_error ("ACTION type conflicts with READONLY specifier at %L",
2251 2 : &open->action->where);
2252 2 : return false;
2253 : }
2254 : }
2255 :
2256 : /* If we see READONLY and no ACTION, set ACTION='READ'. */
2257 3484 : else if (open->readonly && open->action == NULL)
2258 : {
2259 6 : open->action = gfc_get_character_expr (gfc_default_character_kind,
2260 : &gfc_current_locus, "read", 4);
2261 : }
2262 :
2263 : /* Checks on the ASYNCHRONOUS specifier. */
2264 3717 : if (open->asynchronous)
2265 : {
2266 105 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L "
2267 : "not allowed in Fortran 95",
2268 : &open->asynchronous->where))
2269 : return false;
2270 :
2271 105 : if (open->asynchronous->expr_type == EXPR_CONSTANT)
2272 : {
2273 103 : static const char * asynchronous[] = { "YES", "NO", NULL };
2274 :
2275 103 : if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
2276 : NULL, NULL, open->asynchronous->value.character.string,
2277 : "OPEN", warn, &open->asynchronous->where))
2278 : return false;
2279 : }
2280 : }
2281 :
2282 : /* Checks on the BLANK specifier. */
2283 3716 : if (open->blank)
2284 : {
2285 27 : if (open->blank->expr_type == EXPR_CONSTANT)
2286 : {
2287 27 : static const char *blank[] = { "ZERO", "NULL", NULL };
2288 :
2289 27 : if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
2290 : open->blank->value.character.string,
2291 : "OPEN", warn, &open->blank->where))
2292 : return false;
2293 : }
2294 : }
2295 :
2296 : /* Checks on the CARRIAGECONTROL specifier. */
2297 3713 : if (open->cc && open->cc->expr_type == EXPR_CONSTANT)
2298 : {
2299 18 : static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL };
2300 18 : if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL,
2301 : open->cc->value.character.string,
2302 : "OPEN", warn, &open->cc->where))
2303 : return false;
2304 : }
2305 :
2306 : /* Checks on the DECIMAL specifier. */
2307 3713 : if (open->decimal)
2308 : {
2309 38 : if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
2310 : "not allowed in Fortran 95", &open->decimal->where))
2311 : return false;
2312 :
2313 38 : if (open->decimal->expr_type == EXPR_CONSTANT)
2314 : {
2315 38 : static const char * decimal[] = { "COMMA", "POINT", NULL };
2316 :
2317 38 : if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
2318 : open->decimal->value.character.string,
2319 : "OPEN", warn, &open->decimal->where))
2320 : return false;
2321 : }
2322 : }
2323 :
2324 : /* Checks on the DELIM specifier. */
2325 3711 : if (open->delim)
2326 : {
2327 132 : if (open->delim->expr_type == EXPR_CONSTANT)
2328 : {
2329 132 : static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
2330 :
2331 132 : if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
2332 : open->delim->value.character.string,
2333 : "OPEN", warn, &open->delim->where))
2334 : return false;
2335 : }
2336 : }
2337 :
2338 : /* Checks on the ENCODING specifier. */
2339 3708 : if (open->encoding)
2340 : {
2341 62 : if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L "
2342 : "not allowed in Fortran 95", &open->encoding->where))
2343 : return false;
2344 :
2345 62 : if (open->encoding->expr_type == EXPR_CONSTANT)
2346 : {
2347 62 : static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
2348 :
2349 62 : if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
2350 : open->encoding->value.character.string,
2351 : "OPEN", warn, &open->encoding->where))
2352 : return false;
2353 : }
2354 : }
2355 :
2356 : /* Checks on the FORM specifier. */
2357 3706 : if (open->form && open->form->expr_type == EXPR_CONSTANT)
2358 : {
2359 1082 : static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
2360 :
2361 1082 : if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
2362 : open->form->value.character.string,
2363 : "OPEN", warn, &open->form->where))
2364 : return false;
2365 : }
2366 :
2367 : /* Checks on the PAD specifier. */
2368 3703 : if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
2369 : {
2370 44 : static const char *pad[] = { "YES", "NO", NULL };
2371 :
2372 44 : if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
2373 : open->pad->value.character.string,
2374 : "OPEN", warn, &open->pad->where))
2375 : return false;
2376 : }
2377 :
2378 : /* Checks on the POSITION specifier. */
2379 3701 : if (open->position && open->position->expr_type == EXPR_CONSTANT)
2380 : {
2381 125 : static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
2382 :
2383 125 : if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2384 : open->position->value.character.string,
2385 : "OPEN", warn, &open->position->where))
2386 : return false;
2387 : }
2388 :
2389 : /* Checks on the ROUND specifier. */
2390 3698 : if (open->round)
2391 : {
2392 2 : if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
2393 : "not allowed in Fortran 95", &open->round->where))
2394 : return false;
2395 :
2396 2 : if (open->round->expr_type == EXPR_CONSTANT)
2397 : {
2398 2 : static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2399 : "COMPATIBLE", "PROCESSOR_DEFINED",
2400 : NULL };
2401 :
2402 2 : if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2403 : open->round->value.character.string,
2404 : "OPEN", warn, &open->round->where))
2405 : return false;
2406 : }
2407 : }
2408 :
2409 : /* Checks on the SHARE specifier. */
2410 3696 : if (open->share && open->share->expr_type == EXPR_CONSTANT)
2411 : {
2412 24 : static const char *share[] = { "DENYNONE", "DENYRW", NULL };
2413 24 : if (!compare_to_allowed_values ("SHARE", share, NULL, NULL,
2414 : open->share->value.character.string,
2415 : "OPEN", warn, &open->share->where))
2416 : return false;
2417 : }
2418 :
2419 : /* Checks on the SIGN specifier. */
2420 3696 : if (open->sign)
2421 : {
2422 20 : if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
2423 : "not allowed in Fortran 95", &open->sign->where))
2424 : return false;
2425 :
2426 20 : if (open->sign->expr_type == EXPR_CONSTANT)
2427 : {
2428 20 : static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2429 : NULL };
2430 :
2431 20 : if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2432 : open->sign->value.character.string,
2433 : "OPEN", warn, &open->sign->where))
2434 : return false;
2435 : }
2436 : }
2437 :
2438 : /* Checks on the RECL specifier. */
2439 3694 : if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2440 212 : && open->recl->ts.type == BT_INTEGER
2441 212 : && mpz_sgn (open->recl->value.integer) != 1)
2442 : {
2443 6 : warn_or_error (G_("RECL in OPEN statement at %L must be positive"),
2444 4 : &open->recl->where);
2445 : }
2446 :
2447 : /* Checks on the STATUS specifier. */
2448 3692 : if (open->status && open->status->expr_type == EXPR_CONSTANT)
2449 : {
2450 2124 : static const char *status[] = { "OLD", "NEW", "SCRATCH",
2451 : "REPLACE", "UNKNOWN", NULL };
2452 :
2453 2124 : if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2454 : open->status->value.character.string,
2455 : "OPEN", warn, &open->status->where))
2456 : return false;
2457 :
2458 : /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2459 : the FILE= specifier shall appear. */
2460 2121 : if (open->file == NULL
2461 2121 : && (gfc_wide_strncasecmp (open->status->value.character.string,
2462 : "replace", 7) == 0
2463 1610 : || gfc_wide_strncasecmp (open->status->value.character.string,
2464 : "new", 3) == 0))
2465 : {
2466 6 : char *s = gfc_widechar_to_char (open->status->value.character.string,
2467 : -1);
2468 6 : warn_or_error (G_("The STATUS specified in OPEN statement at %L is "
2469 : "%qs and no FILE specifier is present"),
2470 4 : &open->status->where, s);
2471 4 : free (s);
2472 : }
2473 :
2474 : /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2475 : the FILE= specifier shall not appear. */
2476 2119 : if (gfc_wide_strncasecmp (open->status->value.character.string,
2477 2119 : "scratch", 7) == 0 && open->file)
2478 : {
2479 3 : warn_or_error (G_("The STATUS specified in OPEN statement at %L "
2480 : "cannot have the value SCRATCH if a FILE specifier "
2481 2 : "is present"), &open->status->where);
2482 : }
2483 : }
2484 :
2485 : /* Checks on NEWUNIT specifier. */
2486 3686 : if (open->newunit)
2487 : {
2488 143 : if (open->unit)
2489 : {
2490 0 : gfc_error ("UNIT specifier not allowed with NEWUNIT at %L",
2491 : &open->newunit->where);
2492 0 : return false;
2493 : }
2494 :
2495 143 : if (!open->file &&
2496 27 : (!open->status ||
2497 26 : (open->status->expr_type == EXPR_CONSTANT
2498 25 : && gfc_wide_strncasecmp (open->status->value.character.string,
2499 : "scratch", 7) != 0)))
2500 : {
2501 1 : gfc_error ("NEWUNIT specifier must have FILE= "
2502 1 : "or STATUS='scratch' at %L", &open->newunit->where);
2503 1 : return false;
2504 : }
2505 : }
2506 3543 : else if (!open->unit)
2507 : {
2508 2 : gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified",
2509 : where);
2510 2 : return false;
2511 : }
2512 :
2513 : /* Things that are not allowed for unformatted I/O. */
2514 1085 : if (open->form && open->form->expr_type == EXPR_CONSTANT
2515 1079 : && (open->delim || open->decimal || open->encoding || open->round
2516 1064 : || open->sign || open->pad || open->blank)
2517 3704 : && gfc_wide_strncasecmp (open->form->value.character.string,
2518 : "unformatted", 11) == 0)
2519 : {
2520 9 : locus *loc;
2521 9 : const char *spec;
2522 9 : if (open->delim)
2523 : {
2524 3 : loc = &open->delim->where;
2525 3 : spec = "DELIM ";
2526 : }
2527 6 : else if (open->pad)
2528 : {
2529 3 : loc = &open->pad->where;
2530 3 : spec = "PAD ";
2531 : }
2532 3 : else if (open->blank)
2533 : {
2534 3 : loc = &open->blank->where;
2535 3 : spec = "BLANK ";
2536 : }
2537 : else
2538 : {
2539 : loc = where;
2540 : spec = "";
2541 : }
2542 :
2543 9 : warn_or_error (G_("%sspecifier at %L not allowed in OPEN statement for "
2544 6 : "unformatted I/O"), spec, loc);
2545 : }
2546 :
2547 246 : if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2548 3904 : && gfc_wide_strncasecmp (open->access->value.character.string,
2549 : "stream", 6) == 0)
2550 : {
2551 0 : warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for "
2552 0 : "stream I/O"), &open->recl->where);
2553 : }
2554 :
2555 3680 : if (open->position
2556 122 : && open->access && open->access->expr_type == EXPR_CONSTANT
2557 3728 : && !(gfc_wide_strncasecmp (open->access->value.character.string,
2558 : "sequential", 10) == 0
2559 39 : || gfc_wide_strncasecmp (open->access->value.character.string,
2560 : "stream", 6) == 0
2561 9 : || gfc_wide_strncasecmp (open->access->value.character.string,
2562 : "append", 6) == 0))
2563 : {
2564 3 : warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed "
2565 2 : "for stream or sequential ACCESS"), &open->position->where);
2566 : }
2567 :
2568 : return true;
2569 : #undef warn_or_error
2570 : }
2571 :
2572 :
2573 : /* Match an OPEN statement. */
2574 :
2575 : match
2576 3923 : gfc_match_open (void)
2577 : {
2578 3923 : gfc_open *open;
2579 3923 : match m;
2580 :
2581 3923 : m = gfc_match_char ('(');
2582 3923 : if (m == MATCH_NO)
2583 : return m;
2584 :
2585 3923 : open = XCNEW (gfc_open);
2586 :
2587 3923 : m = match_open_element (open);
2588 :
2589 3923 : if (m == MATCH_ERROR)
2590 0 : goto cleanup;
2591 3923 : if (m == MATCH_NO)
2592 : {
2593 2832 : m = gfc_match_expr (&open->unit);
2594 2832 : if (m == MATCH_ERROR)
2595 0 : goto cleanup;
2596 : }
2597 :
2598 11125 : for (;;)
2599 : {
2600 11125 : if (gfc_match_char (')') == MATCH_YES)
2601 : break;
2602 7219 : if (gfc_match_char (',') != MATCH_YES)
2603 0 : goto syntax;
2604 :
2605 7219 : m = match_open_element (open);
2606 7219 : if (m == MATCH_ERROR)
2607 17 : goto cleanup;
2608 7202 : if (m == MATCH_NO)
2609 0 : goto syntax;
2610 : }
2611 :
2612 3906 : if (gfc_match_eos () == MATCH_NO)
2613 0 : goto syntax;
2614 :
2615 3906 : if (gfc_pure (NULL))
2616 : {
2617 0 : gfc_error ("OPEN statement not allowed in PURE procedure at %C");
2618 0 : goto cleanup;
2619 : }
2620 :
2621 3906 : gfc_unset_implicit_pure (NULL);
2622 :
2623 3906 : new_st.op = EXEC_OPEN;
2624 3906 : new_st.ext.open = open;
2625 3906 : return MATCH_YES;
2626 :
2627 0 : syntax:
2628 0 : gfc_syntax_error (ST_OPEN);
2629 :
2630 17 : cleanup:
2631 17 : gfc_free_open (open);
2632 17 : return MATCH_ERROR;
2633 : }
2634 :
2635 :
2636 : /* Free a gfc_close structure an all its expressions. */
2637 :
2638 : void
2639 3094 : gfc_free_close (gfc_close *close)
2640 : {
2641 3094 : if (close == NULL)
2642 : return;
2643 :
2644 3094 : gfc_free_expr (close->unit);
2645 3094 : gfc_free_expr (close->iomsg);
2646 3094 : gfc_free_expr (close->iostat);
2647 3094 : gfc_free_expr (close->status);
2648 3094 : free (close);
2649 : }
2650 :
2651 :
2652 : /* Match elements of a CLOSE statement. */
2653 :
2654 : static match
2655 4566 : match_close_element (gfc_close *close)
2656 : {
2657 4566 : match m;
2658 :
2659 4566 : m = match_etag (&tag_unit, &close->unit);
2660 4566 : if (m != MATCH_NO)
2661 : return m;
2662 4255 : m = match_etag (&tag_status, &close->status);
2663 4255 : if (m != MATCH_NO)
2664 : return m;
2665 2848 : m = match_etag (&tag_iomsg, &close->iomsg);
2666 2848 : if (m != MATCH_NO)
2667 : return m;
2668 2819 : m = match_out_tag (&tag_iostat, &close->iostat);
2669 2819 : if (m != MATCH_NO)
2670 : return m;
2671 2792 : m = match_ltag (&tag_err, &close->err);
2672 2792 : if (m != MATCH_NO)
2673 : return m;
2674 :
2675 : return MATCH_NO;
2676 : }
2677 :
2678 :
2679 : /* Match a CLOSE statement. */
2680 :
2681 : match
2682 3094 : gfc_match_close (void)
2683 : {
2684 3094 : gfc_close *close;
2685 3094 : match m;
2686 :
2687 3094 : m = gfc_match_char ('(');
2688 3094 : if (m == MATCH_NO)
2689 : return m;
2690 :
2691 3094 : close = XCNEW (gfc_close);
2692 :
2693 3094 : m = match_close_element (close);
2694 :
2695 3094 : if (m == MATCH_ERROR)
2696 0 : goto cleanup;
2697 3094 : if (m == MATCH_NO)
2698 : {
2699 2782 : m = gfc_match_expr (&close->unit);
2700 2782 : if (m == MATCH_NO)
2701 0 : goto syntax;
2702 2782 : if (m == MATCH_ERROR)
2703 0 : goto cleanup;
2704 : }
2705 :
2706 4566 : for (;;)
2707 : {
2708 4566 : if (gfc_match_char (')') == MATCH_YES)
2709 : break;
2710 1472 : if (gfc_match_char (',') != MATCH_YES)
2711 0 : goto syntax;
2712 :
2713 1472 : m = match_close_element (close);
2714 1472 : if (m == MATCH_ERROR)
2715 0 : goto cleanup;
2716 1472 : if (m == MATCH_NO)
2717 0 : goto syntax;
2718 : }
2719 :
2720 3094 : if (gfc_match_eos () == MATCH_NO)
2721 0 : goto syntax;
2722 :
2723 3094 : if (gfc_pure (NULL))
2724 : {
2725 0 : gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2726 0 : goto cleanup;
2727 : }
2728 :
2729 3094 : gfc_unset_implicit_pure (NULL);
2730 :
2731 3094 : new_st.op = EXEC_CLOSE;
2732 3094 : new_st.ext.close = close;
2733 3094 : return MATCH_YES;
2734 :
2735 0 : syntax:
2736 0 : gfc_syntax_error (ST_CLOSE);
2737 :
2738 0 : cleanup:
2739 0 : gfc_free_close (close);
2740 0 : return MATCH_ERROR;
2741 : }
2742 :
2743 :
2744 : static bool
2745 3064 : check_close_constraints (gfc_close *close, locus *where)
2746 : {
2747 3064 : bool warn = (close->iostat || close->err) ? true : false;
2748 :
2749 3064 : if (close->unit == NULL)
2750 : {
2751 1 : gfc_error ("CLOSE statement at %L requires a UNIT number", where);
2752 1 : return false;
2753 : }
2754 :
2755 3063 : if (close->unit->expr_type == EXPR_CONSTANT
2756 2792 : && close->unit->ts.type == BT_INTEGER
2757 2792 : && mpz_sgn (close->unit->value.integer) < 0)
2758 : {
2759 0 : gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2760 : &close->unit->where);
2761 : }
2762 :
2763 : /* Checks on the STATUS specifier. */
2764 3063 : if (close->status && close->status->expr_type == EXPR_CONSTANT)
2765 : {
2766 1381 : static const char *status[] = { "KEEP", "DELETE", NULL };
2767 :
2768 1381 : if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2769 : close->status->value.character.string,
2770 : "CLOSE", warn, &close->status->where))
2771 : return false;
2772 : }
2773 :
2774 : return true;
2775 : }
2776 :
2777 : /* Resolve everything in a gfc_close structure. */
2778 :
2779 : bool
2780 3094 : gfc_resolve_close (gfc_close *close, locus *where)
2781 : {
2782 3094 : RESOLVE_TAG (&tag_unit, close->unit);
2783 3094 : RESOLVE_TAG (&tag_iomsg, close->iomsg);
2784 3077 : RESOLVE_TAG (&tag_iostat, close->iostat);
2785 3075 : RESOLVE_TAG (&tag_status, close->status);
2786 :
2787 3064 : if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
2788 : return false;
2789 :
2790 3064 : return check_close_constraints (close, where);
2791 : }
2792 :
2793 :
2794 : /* Free a gfc_filepos structure. */
2795 :
2796 : void
2797 2825 : gfc_free_filepos (gfc_filepos *fp)
2798 : {
2799 2825 : gfc_free_expr (fp->unit);
2800 2825 : gfc_free_expr (fp->iomsg);
2801 2825 : gfc_free_expr (fp->iostat);
2802 2825 : free (fp);
2803 2825 : }
2804 :
2805 :
2806 : /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2807 :
2808 : static match
2809 2522 : match_file_element (gfc_filepos *fp)
2810 : {
2811 2522 : match m;
2812 :
2813 2522 : m = match_etag (&tag_unit, &fp->unit);
2814 2522 : if (m != MATCH_NO)
2815 : return m;
2816 2489 : m = match_etag (&tag_iomsg, &fp->iomsg);
2817 2489 : if (m != MATCH_NO)
2818 : return m;
2819 2401 : m = match_out_tag (&tag_iostat, &fp->iostat);
2820 2401 : if (m != MATCH_NO)
2821 : return m;
2822 2323 : m = match_ltag (&tag_err, &fp->err);
2823 2323 : if (m != MATCH_NO)
2824 : return m;
2825 :
2826 : return MATCH_NO;
2827 : }
2828 :
2829 :
2830 : /* Match the second half of the file-positioning statements, REWIND,
2831 : BACKSPACE, ENDFILE, or the FLUSH statement. */
2832 :
2833 : static match
2834 2825 : match_filepos (gfc_statement st, gfc_exec_op op)
2835 : {
2836 2825 : gfc_filepos *fp;
2837 2825 : match m;
2838 :
2839 2825 : fp = XCNEW (gfc_filepos);
2840 :
2841 2825 : if (gfc_match_char ('(') == MATCH_NO)
2842 : {
2843 480 : m = gfc_match_expr (&fp->unit);
2844 480 : if (m == MATCH_ERROR)
2845 0 : goto cleanup;
2846 480 : if (m == MATCH_NO)
2847 0 : goto syntax;
2848 :
2849 480 : goto done;
2850 : }
2851 :
2852 2345 : m = match_file_element (fp);
2853 2345 : if (m == MATCH_ERROR)
2854 8 : goto cleanup;
2855 2337 : if (m == MATCH_NO)
2856 : {
2857 2299 : m = gfc_match_expr (&fp->unit);
2858 2299 : if (m == MATCH_ERROR || m == MATCH_NO)
2859 8 : goto syntax;
2860 : }
2861 :
2862 2506 : for (;;)
2863 : {
2864 2506 : if (gfc_match_char (')') == MATCH_YES)
2865 : break;
2866 177 : if (gfc_match_char (',') != MATCH_YES)
2867 0 : goto syntax;
2868 :
2869 177 : m = match_file_element (fp);
2870 177 : if (m == MATCH_ERROR)
2871 0 : goto cleanup;
2872 177 : if (m == MATCH_NO)
2873 0 : goto syntax;
2874 : }
2875 :
2876 2329 : done:
2877 2809 : if (gfc_match_eos () != MATCH_YES)
2878 0 : goto syntax;
2879 :
2880 2809 : if (gfc_pure (NULL))
2881 : {
2882 0 : gfc_error ("%s statement not allowed in PURE procedure at %C",
2883 : gfc_ascii_statement (st));
2884 :
2885 0 : goto cleanup;
2886 : }
2887 :
2888 2809 : gfc_unset_implicit_pure (NULL);
2889 :
2890 2809 : new_st.op = op;
2891 2809 : new_st.ext.filepos = fp;
2892 2809 : return MATCH_YES;
2893 :
2894 8 : syntax:
2895 8 : gfc_syntax_error (st);
2896 :
2897 16 : cleanup:
2898 16 : gfc_free_filepos (fp);
2899 16 : return MATCH_ERROR;
2900 : }
2901 :
2902 :
2903 : bool
2904 2809 : gfc_resolve_filepos (gfc_filepos *fp, locus *where)
2905 : {
2906 2809 : RESOLVE_TAG (&tag_unit, fp->unit);
2907 2809 : RESOLVE_TAG (&tag_iostat, fp->iostat);
2908 2806 : RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2909 :
2910 2748 : if (!fp->unit && (fp->iostat || fp->iomsg || fp->err))
2911 : {
2912 5 : gfc_error ("UNIT number missing in statement at %L", where);
2913 5 : return false;
2914 : }
2915 :
2916 2743 : if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
2917 : return false;
2918 :
2919 2743 : if (fp->unit->expr_type == EXPR_CONSTANT
2920 2554 : && fp->unit->ts.type == BT_INTEGER
2921 2554 : && mpz_sgn (fp->unit->value.integer) < 0)
2922 : {
2923 0 : gfc_error ("UNIT number in statement at %L must be non-negative",
2924 : &fp->unit->where);
2925 0 : return false;
2926 : }
2927 :
2928 : return true;
2929 : }
2930 :
2931 :
2932 : /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2933 : and the FLUSH statement. */
2934 :
2935 : match
2936 75 : gfc_match_endfile (void)
2937 : {
2938 75 : return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2939 : }
2940 :
2941 : match
2942 412 : gfc_match_backspace (void)
2943 : {
2944 412 : return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2945 : }
2946 :
2947 : match
2948 2239 : gfc_match_rewind (void)
2949 : {
2950 2239 : return match_filepos (ST_REWIND, EXEC_REWIND);
2951 : }
2952 :
2953 : match
2954 99 : gfc_match_flush (void)
2955 : {
2956 99 : if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
2957 : return MATCH_ERROR;
2958 :
2959 99 : return match_filepos (ST_FLUSH, EXEC_FLUSH);
2960 : }
2961 :
2962 : /******************** Data Transfer Statements *********************/
2963 :
2964 : /* Return a default unit number. */
2965 :
2966 : static gfc_expr *
2967 11642 : default_unit (io_kind k)
2968 : {
2969 11642 : int unit;
2970 :
2971 11642 : if (k == M_READ)
2972 : unit = 5;
2973 : else
2974 11568 : unit = 6;
2975 :
2976 11642 : return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2977 : }
2978 :
2979 :
2980 : /* Match a unit specification for a data transfer statement. */
2981 :
2982 : static match
2983 25486 : match_dt_unit (io_kind k, gfc_dt *dt)
2984 : {
2985 25486 : gfc_expr *e;
2986 25486 : char c;
2987 :
2988 25486 : if (gfc_match_char ('*') == MATCH_YES)
2989 : {
2990 3958 : if (dt->io_unit != NULL)
2991 0 : goto conflict;
2992 :
2993 3958 : dt->io_unit = default_unit (k);
2994 :
2995 3958 : c = gfc_peek_ascii_char ();
2996 3958 : if (c == ')')
2997 0 : gfc_error_now ("Missing format with default unit at %C");
2998 :
2999 3958 : return MATCH_YES;
3000 : }
3001 :
3002 21528 : if (gfc_match_expr (&e) == MATCH_YES)
3003 : {
3004 21528 : if (dt->io_unit != NULL)
3005 : {
3006 0 : gfc_free_expr (e);
3007 0 : goto conflict;
3008 : }
3009 :
3010 21528 : dt->io_unit = e;
3011 21528 : return MATCH_YES;
3012 : }
3013 :
3014 : return MATCH_NO;
3015 :
3016 0 : conflict:
3017 0 : gfc_error ("Duplicate UNIT specification at %C");
3018 0 : return MATCH_ERROR;
3019 : }
3020 :
3021 :
3022 : /* Match a format specification. */
3023 :
3024 : static match
3025 29821 : match_dt_format (gfc_dt *dt)
3026 : {
3027 29821 : locus where;
3028 29821 : gfc_expr *e;
3029 29821 : gfc_st_label *label;
3030 29821 : match m;
3031 :
3032 29821 : where = gfc_current_locus;
3033 :
3034 29821 : if (gfc_match_char ('*') == MATCH_YES)
3035 : {
3036 15535 : if (dt->format_expr != NULL || dt->format_label != NULL)
3037 0 : goto conflict;
3038 :
3039 15535 : dt->format_label = &format_asterisk;
3040 15535 : return MATCH_YES;
3041 : }
3042 :
3043 14286 : if ((m = gfc_match_st_label (&label)) == MATCH_YES)
3044 : {
3045 1772 : char c;
3046 :
3047 : /* Need to check if the format label is actually either an operand
3048 : to a user-defined operator or is a kind type parameter. That is,
3049 : print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
3050 : print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
3051 :
3052 1772 : gfc_gobble_whitespace ();
3053 1772 : c = gfc_peek_ascii_char ();
3054 1772 : if (c == '.' || c == '_')
3055 2 : gfc_current_locus = where;
3056 : else
3057 : {
3058 1770 : if (dt->format_expr != NULL || dt->format_label != NULL)
3059 : {
3060 0 : gfc_free_st_label (label);
3061 0 : goto conflict;
3062 : }
3063 :
3064 1770 : if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
3065 : return MATCH_ERROR;
3066 :
3067 1765 : dt->format_label = label;
3068 1765 : return MATCH_YES;
3069 : }
3070 : }
3071 12514 : else if (m == MATCH_ERROR)
3072 : /* The label was zero or too large. Emit the correct diagnosis. */
3073 : return MATCH_ERROR;
3074 :
3075 12514 : if (gfc_match_expr (&e) == MATCH_YES)
3076 : {
3077 12087 : if (dt->format_expr != NULL || dt->format_label != NULL)
3078 : {
3079 0 : gfc_free_expr (e);
3080 0 : goto conflict;
3081 : }
3082 12087 : dt->format_expr = e;
3083 12087 : return MATCH_YES;
3084 : }
3085 :
3086 427 : gfc_current_locus = where; /* The only case where we have to restore */
3087 :
3088 427 : return MATCH_NO;
3089 :
3090 0 : conflict:
3091 0 : gfc_error ("Duplicate format specification at %C");
3092 0 : return MATCH_ERROR;
3093 : }
3094 :
3095 : /* Check for formatted read and write DTIO procedures. */
3096 :
3097 : static bool
3098 3020 : dtio_procs_present (gfc_symbol *sym, io_kind k)
3099 : {
3100 3020 : gfc_symbol *derived;
3101 :
3102 3020 : if (sym && sym->ts.u.derived)
3103 : {
3104 1563 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
3105 22 : derived = CLASS_DATA (sym)->ts.u.derived;
3106 1541 : else if (sym->ts.type == BT_DERIVED)
3107 : derived = sym->ts.u.derived;
3108 : else
3109 : return false;
3110 1150 : if ((k == M_WRITE || k == M_PRINT) &&
3111 345 : (gfc_find_specific_dtio_proc (derived, true, true) != NULL))
3112 : return true;
3113 1210 : if ((k == M_READ) &&
3114 460 : (gfc_find_specific_dtio_proc (derived, false, true) != NULL))
3115 : return true;
3116 : }
3117 : return false;
3118 : }
3119 :
3120 : /* Traverse a namelist that is part of a READ statement to make sure
3121 : that none of the variables in the namelist are INTENT(IN). Returns
3122 : nonzero if we find such a variable. */
3123 :
3124 : static int
3125 867 : check_namelist (gfc_symbol *sym)
3126 : {
3127 867 : gfc_namelist *p;
3128 :
3129 2903 : for (p = sym->namelist; p; p = p->next)
3130 2037 : if (p->sym->attr.intent == INTENT_IN)
3131 : {
3132 1 : gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
3133 : p->sym->name, sym->name);
3134 1 : return 1;
3135 : }
3136 :
3137 : return 0;
3138 : }
3139 :
3140 :
3141 : /* Match a single data transfer element. */
3142 :
3143 : static match
3144 53579 : match_dt_element (io_kind k, gfc_dt *dt)
3145 : {
3146 53579 : char name[GFC_MAX_SYMBOL_LEN + 1];
3147 53579 : gfc_symbol *sym;
3148 53579 : match m;
3149 :
3150 53579 : if (gfc_match (" unit =") == MATCH_YES)
3151 : {
3152 1211 : m = match_dt_unit (k, dt);
3153 1211 : if (m != MATCH_NO)
3154 : return m;
3155 : }
3156 :
3157 52368 : if (gfc_match (" fmt =") == MATCH_YES)
3158 : {
3159 2006 : m = match_dt_format (dt);
3160 2006 : if (m != MATCH_NO)
3161 : return m;
3162 : }
3163 :
3164 50362 : if (gfc_match (" nml = %n", name) == MATCH_YES)
3165 : {
3166 770 : if (dt->namelist != NULL)
3167 : {
3168 0 : gfc_error ("Duplicate NML specification at %C");
3169 0 : return MATCH_ERROR;
3170 : }
3171 :
3172 770 : if (gfc_find_symbol (name, NULL, 1, &sym))
3173 : return MATCH_ERROR;
3174 :
3175 770 : if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
3176 : {
3177 0 : gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3178 : sym != NULL ? sym->name : name);
3179 0 : return MATCH_ERROR;
3180 : }
3181 :
3182 770 : dt->namelist = sym;
3183 770 : if (k == M_READ && check_namelist (sym))
3184 : return MATCH_ERROR;
3185 :
3186 770 : return MATCH_YES;
3187 : }
3188 :
3189 49592 : m = match_etag (&tag_e_async, &dt->asynchronous);
3190 49592 : if (m != MATCH_NO)
3191 : return m;
3192 49363 : m = match_etag (&tag_e_blank, &dt->blank);
3193 49363 : if (m != MATCH_NO)
3194 : return m;
3195 49322 : m = match_etag (&tag_e_delim, &dt->delim);
3196 49322 : if (m != MATCH_NO)
3197 : return m;
3198 49293 : m = match_etag (&tag_e_pad, &dt->pad);
3199 49293 : if (m != MATCH_NO)
3200 : return m;
3201 49188 : m = match_etag (&tag_e_sign, &dt->sign);
3202 49188 : if (m != MATCH_NO)
3203 : return m;
3204 49149 : m = match_etag (&tag_e_round, &dt->round);
3205 49149 : if (m != MATCH_NO)
3206 : return m;
3207 48810 : m = match_out_tag (&tag_id, &dt->id);
3208 48810 : if (m != MATCH_NO)
3209 : return m;
3210 48789 : m = match_etag (&tag_e_decimal, &dt->decimal);
3211 48789 : if (m != MATCH_NO)
3212 : return m;
3213 48621 : m = match_etag (&tag_rec, &dt->rec);
3214 48621 : if (m != MATCH_NO)
3215 : return m;
3216 48121 : m = match_etag (&tag_spos, &dt->pos);
3217 48121 : if (m != MATCH_NO)
3218 : return m;
3219 47949 : m = match_etag (&tag_iomsg, &dt->iomsg);
3220 47949 : if (m != MATCH_NO)
3221 : return m;
3222 :
3223 47494 : m = match_out_tag (&tag_iostat, &dt->iostat);
3224 47494 : if (m != MATCH_NO)
3225 : return m;
3226 45704 : m = match_ltag (&tag_err, &dt->err);
3227 45704 : if (m == MATCH_YES)
3228 250 : dt->err_where = gfc_current_locus;
3229 45704 : if (m != MATCH_NO)
3230 : return m;
3231 45454 : m = match_etag (&tag_advance, &dt->advance);
3232 45454 : if (m != MATCH_NO)
3233 : return m;
3234 45071 : m = match_out_tag (&tag_size, &dt->size);
3235 45071 : if (m != MATCH_NO)
3236 : return m;
3237 :
3238 45006 : m = match_ltag (&tag_end, &dt->end);
3239 45006 : if (m == MATCH_YES)
3240 : {
3241 562 : if (k == M_WRITE)
3242 : {
3243 4 : gfc_error ("END tag at %C not allowed in output statement");
3244 4 : return MATCH_ERROR;
3245 : }
3246 558 : dt->end_where = gfc_current_locus;
3247 : }
3248 45002 : if (m != MATCH_NO)
3249 : return m;
3250 :
3251 44444 : m = match_ltag (&tag_eor, &dt->eor);
3252 44444 : if (m == MATCH_YES)
3253 34 : dt->eor_where = gfc_current_locus;
3254 44444 : if (m != MATCH_NO)
3255 : return m;
3256 :
3257 : return MATCH_NO;
3258 : }
3259 :
3260 :
3261 : /* Free a data transfer structure and everything below it. */
3262 :
3263 : void
3264 66025 : gfc_free_dt (gfc_dt *dt)
3265 : {
3266 66025 : if (dt == NULL)
3267 : return;
3268 :
3269 33081 : gfc_free_expr (dt->io_unit);
3270 33081 : gfc_free_expr (dt->format_expr);
3271 33081 : gfc_free_expr (dt->rec);
3272 33081 : gfc_free_expr (dt->advance);
3273 33081 : gfc_free_expr (dt->iomsg);
3274 33081 : gfc_free_expr (dt->iostat);
3275 33081 : gfc_free_expr (dt->size);
3276 33081 : gfc_free_expr (dt->pad);
3277 33081 : gfc_free_expr (dt->delim);
3278 33081 : gfc_free_expr (dt->sign);
3279 33081 : gfc_free_expr (dt->round);
3280 33081 : gfc_free_expr (dt->blank);
3281 33081 : gfc_free_expr (dt->decimal);
3282 33081 : gfc_free_expr (dt->pos);
3283 33081 : gfc_free_expr (dt->dt_io_kind);
3284 : /* dt->extra_comma is a link to dt_io_kind if it is set. */
3285 33081 : free (dt);
3286 : }
3287 :
3288 :
3289 : static const char *
3290 : io_kind_name (io_kind k);
3291 :
3292 : static bool
3293 : check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3294 : locus *spec_end);
3295 :
3296 : /* Resolve everything in a gfc_dt structure. */
3297 :
3298 : bool
3299 33010 : gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc)
3300 : {
3301 33010 : gfc_expr *e;
3302 33010 : io_kind k;
3303 :
3304 : /* This is set in any case. */
3305 33010 : gcc_assert (dt->dt_io_kind);
3306 33010 : k = dt->dt_io_kind->value.iokind;
3307 :
3308 33010 : RESOLVE_TAG (&tag_format, dt->format_expr);
3309 32982 : RESOLVE_TAG (&tag_rec, dt->rec);
3310 32982 : RESOLVE_TAG (&tag_spos, dt->pos);
3311 32982 : RESOLVE_TAG (&tag_advance, dt->advance);
3312 32979 : RESOLVE_TAG (&tag_id, dt->id);
3313 32979 : RESOLVE_TAG (&tag_iomsg, dt->iomsg);
3314 32950 : RESOLVE_TAG (&tag_iostat, dt->iostat);
3315 32947 : RESOLVE_TAG (&tag_size, dt->size);
3316 32943 : RESOLVE_TAG (&tag_e_pad, dt->pad);
3317 32921 : RESOLVE_TAG (&tag_e_delim, dt->delim);
3318 32899 : RESOLVE_TAG (&tag_e_sign, dt->sign);
3319 32877 : RESOLVE_TAG (&tag_e_round, dt->round);
3320 32855 : RESOLVE_TAG (&tag_e_blank, dt->blank);
3321 32833 : RESOLVE_TAG (&tag_e_decimal, dt->decimal);
3322 32813 : RESOLVE_TAG (&tag_e_async, dt->asynchronous);
3323 :
3324 : /* Check I/O constraints.
3325 : To validate NAMELIST we need to check if we were also given an I/O list,
3326 : which is stored in code->block->next with op EXEC_TRANSFER.
3327 : Note that the I/O list was already resolved from resolve_transfer. */
3328 32790 : gfc_code *io_code = NULL;
3329 32790 : if (dt_code && dt_code->block && dt_code->block->next
3330 32790 : && dt_code->block->next->op == EXEC_TRANSFER)
3331 32790 : io_code = dt_code->block->next;
3332 :
3333 32790 : if (!check_io_constraints (k, dt, io_code, loc))
3334 : return false;
3335 :
3336 32731 : e = dt->io_unit;
3337 32731 : if (e == NULL)
3338 : {
3339 2 : gfc_error ("UNIT not specified at %L", loc);
3340 2 : return false;
3341 : }
3342 :
3343 32729 : if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER
3344 365 : && e->ts.type == BT_CHARACTER)
3345 : {
3346 4 : gfc_error ("UNIT specification at %L must "
3347 : "not be a character PARAMETER", &e->where);
3348 4 : return false;
3349 : }
3350 :
3351 32725 : if (gfc_resolve_expr (e)
3352 32725 : && (e->ts.type != BT_INTEGER
3353 9794 : && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
3354 : {
3355 : /* If there is no extra comma signifying the "format" form of the IO
3356 : statement, then this must be an error. */
3357 2 : if (!dt->extra_comma)
3358 : {
3359 1 : gfc_error ("UNIT specification at %L must be an INTEGER expression "
3360 : "or a CHARACTER variable", &e->where);
3361 1 : return false;
3362 : }
3363 : else
3364 : {
3365 : /* At this point, we have an extra comma. If io_unit has arrived as
3366 : type character, we assume its really the "format" form of the I/O
3367 : statement. We set the io_unit to the default unit and format to
3368 : the character expression. See F95 Standard section 9.4. */
3369 1 : if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
3370 : {
3371 0 : dt->format_expr = dt->io_unit;
3372 0 : dt->io_unit = default_unit (k);
3373 :
3374 : /* Nullify this pointer now so that a warning/error is not
3375 : triggered below for the "Extension". */
3376 0 : dt->extra_comma = NULL;
3377 : }
3378 :
3379 1 : if (k == M_WRITE)
3380 : {
3381 1 : gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3382 1 : &dt->extra_comma->where);
3383 1 : return false;
3384 : }
3385 : }
3386 : }
3387 :
3388 32723 : if (e->ts.type == BT_CHARACTER)
3389 : {
3390 9792 : if (gfc_has_vector_index (e))
3391 : {
3392 3 : gfc_error ("Internal unit with vector subscript at %L", &e->where);
3393 3 : return false;
3394 : }
3395 :
3396 : /* If we are writing, make sure the internal unit can be changed. */
3397 9789 : gcc_assert (k != M_PRINT);
3398 9789 : if (k == M_WRITE
3399 17822 : && !gfc_check_vardef_context (e, false, false, false,
3400 8033 : _("internal unit in WRITE")))
3401 : return false;
3402 : }
3403 :
3404 32719 : if (e->rank && e->ts.type != BT_CHARACTER)
3405 : {
3406 1 : gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
3407 1 : return false;
3408 : }
3409 :
3410 32718 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
3411 21410 : && mpz_sgn (e->value.integer) < 0)
3412 : {
3413 0 : gfc_error ("UNIT number in statement at %L must be non-negative",
3414 : &e->where);
3415 0 : return false;
3416 : }
3417 :
3418 : /* If we are reading and have a namelist, check that all namelist symbols
3419 : can appear in a variable definition context. */
3420 32718 : if (dt->namelist)
3421 : {
3422 1193 : gfc_namelist* n;
3423 4208 : for (n = dt->namelist->namelist; n; n = n->next)
3424 : {
3425 3021 : gfc_expr* e;
3426 3021 : bool t;
3427 :
3428 3021 : if (k == M_READ)
3429 : {
3430 2035 : e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
3431 2035 : t = gfc_check_vardef_context (e, false, false, false, NULL);
3432 2035 : gfc_free_expr (e);
3433 :
3434 2035 : if (!t)
3435 : {
3436 1 : gfc_error ("NAMELIST %qs in READ statement at %L contains"
3437 : " the symbol %qs which may not appear in a"
3438 : " variable definition context",
3439 1 : dt->namelist->name, loc, n->sym->name);
3440 1 : return false;
3441 : }
3442 : }
3443 :
3444 3020 : t = dtio_procs_present (n->sym, k);
3445 :
3446 3020 : if (n->sym->ts.type == BT_CLASS && !t)
3447 : {
3448 3 : gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3449 : "polymorphic and requires a defined input/output "
3450 3 : "procedure", n->sym->name, dt->namelist->name, loc);
3451 3 : return false;
3452 : }
3453 :
3454 3017 : if ((n->sym->ts.type == BT_DERIVED)
3455 783 : && (n->sym->ts.u.derived->attr.alloc_comp
3456 781 : || n->sym->ts.u.derived->attr.pointer_comp))
3457 : {
3458 2 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
3459 : "namelist %qs at %L with ALLOCATABLE "
3460 : "or POINTER components", n->sym->name,
3461 2 : dt->namelist->name, loc))
3462 : return false;
3463 :
3464 2 : if (!t)
3465 : {
3466 2 : gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3467 : "ALLOCATABLE or POINTER components and thus requires "
3468 2 : "a defined input/output procedure", n->sym->name,
3469 2 : dt->namelist->name, loc);
3470 2 : return false;
3471 : }
3472 : }
3473 : }
3474 : }
3475 :
3476 32712 : if (dt->extra_comma
3477 32712 : && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L",
3478 : &dt->extra_comma->where))
3479 : return false;
3480 :
3481 32712 : if (dt->err)
3482 : {
3483 250 : if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
3484 : return false;
3485 250 : if (dt->err->defined == ST_LABEL_UNKNOWN)
3486 : {
3487 1 : gfc_error ("ERR tag label %d at %L not defined",
3488 : dt->err->value, &dt->err_where);
3489 1 : return false;
3490 : }
3491 : }
3492 :
3493 32711 : if (dt->end)
3494 : {
3495 557 : if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
3496 : return false;
3497 557 : if (dt->end->defined == ST_LABEL_UNKNOWN)
3498 : {
3499 1 : gfc_error ("END tag label %d at %L not defined",
3500 : dt->end->value, &dt->end_where);
3501 1 : return false;
3502 : }
3503 : }
3504 :
3505 32710 : if (dt->eor)
3506 : {
3507 31 : if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
3508 : return false;
3509 31 : if (dt->eor->defined == ST_LABEL_UNKNOWN)
3510 : {
3511 1 : gfc_error ("EOR tag label %d at %L not defined",
3512 : dt->eor->value, &dt->eor_where);
3513 1 : return false;
3514 : }
3515 : }
3516 :
3517 : /* Check the format label actually exists. */
3518 32709 : if (dt->format_label && dt->format_label != &format_asterisk
3519 1767 : && dt->format_label->defined == ST_LABEL_UNKNOWN)
3520 : {
3521 7 : gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
3522 : loc);
3523 7 : return false;
3524 : }
3525 :
3526 : return true;
3527 : }
3528 :
3529 :
3530 : /* Given an io_kind, return its name. */
3531 :
3532 : static const char *
3533 811 : io_kind_name (io_kind k)
3534 : {
3535 811 : const char *name;
3536 :
3537 811 : switch (k)
3538 : {
3539 : case M_READ:
3540 : name = "READ";
3541 : break;
3542 499 : case M_WRITE:
3543 499 : name = "WRITE";
3544 499 : break;
3545 26 : case M_PRINT:
3546 26 : name = "PRINT";
3547 26 : break;
3548 0 : case M_INQUIRE:
3549 0 : name = "INQUIRE";
3550 0 : break;
3551 0 : default:
3552 0 : gfc_internal_error ("io_kind_name(): bad I/O-kind");
3553 : }
3554 :
3555 811 : return name;
3556 : }
3557 :
3558 :
3559 : /* Match an IO iteration statement of the form:
3560 :
3561 : ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3562 :
3563 : which is equivalent to a single IO element. This function is
3564 : mutually recursive with match_io_element(). */
3565 :
3566 : static match match_io_element (io_kind, gfc_code **);
3567 :
3568 : static match
3569 48012 : match_io_iterator (io_kind k, gfc_code **result)
3570 : {
3571 48012 : gfc_code *head, *tail, *new_code;
3572 48012 : gfc_iterator *iter;
3573 48012 : locus old_loc;
3574 48012 : match m;
3575 48012 : int n;
3576 :
3577 48012 : iter = NULL;
3578 48012 : head = NULL;
3579 48012 : old_loc = gfc_current_locus;
3580 :
3581 48012 : if (gfc_match_char ('(') != MATCH_YES)
3582 : return MATCH_NO;
3583 :
3584 763 : m = match_io_element (k, &head);
3585 763 : tail = head;
3586 :
3587 763 : if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3588 : {
3589 92 : m = MATCH_NO;
3590 92 : goto cleanup;
3591 : }
3592 :
3593 : /* Can't be anything but an IO iterator. Build a list. */
3594 671 : iter = gfc_get_iterator ();
3595 :
3596 671 : for (n = 1;; n++)
3597 : {
3598 723 : m = gfc_match_iterator (iter, 0);
3599 723 : if (m == MATCH_ERROR)
3600 0 : goto cleanup;
3601 723 : if (m == MATCH_YES)
3602 : {
3603 654 : gfc_check_do_variable (iter->var->symtree);
3604 654 : break;
3605 : }
3606 :
3607 69 : m = match_io_element (k, &new_code);
3608 69 : if (m == MATCH_ERROR)
3609 0 : goto cleanup;
3610 69 : if (m == MATCH_NO)
3611 : {
3612 : if (n > 2)
3613 : goto syntax;
3614 : goto cleanup;
3615 : }
3616 :
3617 69 : tail = gfc_append_code (tail, new_code);
3618 :
3619 69 : if (gfc_match_char (',') != MATCH_YES)
3620 : {
3621 17 : if (n > 2)
3622 0 : goto syntax;
3623 17 : m = MATCH_NO;
3624 17 : goto cleanup;
3625 : }
3626 : }
3627 :
3628 654 : if (gfc_match_char (')') != MATCH_YES)
3629 1 : goto syntax;
3630 :
3631 653 : new_code = gfc_get_code (EXEC_DO);
3632 653 : new_code->ext.iterator = iter;
3633 :
3634 653 : new_code->block = gfc_get_code (EXEC_DO);
3635 653 : new_code->block->next = head;
3636 :
3637 653 : *result = new_code;
3638 653 : return MATCH_YES;
3639 :
3640 1 : syntax:
3641 1 : gfc_error ("Syntax error in I/O iterator at %C");
3642 1 : m = MATCH_ERROR;
3643 :
3644 110 : cleanup:
3645 110 : gfc_free_iterator (iter, 1);
3646 110 : gfc_free_statements (head);
3647 110 : gfc_current_locus = old_loc;
3648 110 : return m;
3649 : }
3650 :
3651 :
3652 : /* Match a single element of an IO list, which is either a single
3653 : expression or an IO Iterator. */
3654 :
3655 : static match
3656 48012 : match_io_element (io_kind k, gfc_code **cpp)
3657 : {
3658 48012 : gfc_expr *expr;
3659 48012 : gfc_code *cp;
3660 48012 : match m;
3661 :
3662 48012 : expr = NULL;
3663 :
3664 48012 : m = match_io_iterator (k, cpp);
3665 48012 : if (m == MATCH_YES)
3666 : return MATCH_YES;
3667 :
3668 47359 : if (k == M_READ)
3669 : {
3670 7340 : m = gfc_match_variable (&expr, 0);
3671 7340 : if (m == MATCH_NO)
3672 : {
3673 0 : gfc_error ("Expecting variable in READ statement at %C");
3674 0 : m = MATCH_ERROR;
3675 : }
3676 :
3677 7340 : if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT)
3678 : {
3679 1 : gfc_error ("Expecting variable or io-implied-do in READ statement "
3680 : "at %L", &expr->where);
3681 1 : m = MATCH_ERROR;
3682 : }
3683 :
3684 7340 : if (m == MATCH_YES
3685 7339 : && expr->expr_type == EXPR_VARIABLE
3686 7339 : && expr->symtree->n.sym->attr.external)
3687 : {
3688 2 : gfc_error ("Expecting variable or io-implied-do at %L",
3689 : &expr->where);
3690 2 : m = MATCH_ERROR;
3691 : }
3692 : }
3693 : else
3694 : {
3695 40019 : m = gfc_match_expr (&expr);
3696 40019 : if (m == MATCH_NO)
3697 41 : gfc_error ("Expected expression in %s statement at %C",
3698 : io_kind_name (k));
3699 :
3700 40019 : if (m == MATCH_YES && expr->ts.type == BT_BOZ)
3701 : {
3702 6 : if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in"
3703 : " an output IO list"), &gfc_current_locus))
3704 : return MATCH_ERROR;
3705 3 : if (!gfc_boz2int (expr, gfc_max_integer_kind))
3706 : return MATCH_ERROR;
3707 47356 : };
3708 : }
3709 :
3710 47356 : if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3711 : m = MATCH_ERROR;
3712 :
3713 47355 : if (m != MATCH_YES)
3714 : {
3715 142 : gfc_free_expr (expr);
3716 142 : return MATCH_ERROR;
3717 : }
3718 :
3719 47214 : cp = gfc_get_code (EXEC_TRANSFER);
3720 47214 : cp->expr1 = expr;
3721 47214 : if (k != M_INQUIRE)
3722 47060 : cp->ext.dt = current_dt;
3723 :
3724 47214 : *cpp = cp;
3725 47214 : return MATCH_YES;
3726 : }
3727 :
3728 :
3729 : /* Match an I/O list, building gfc_code structures as we go. */
3730 :
3731 : static match
3732 31085 : match_io_list (io_kind k, gfc_code **head_p)
3733 : {
3734 31085 : gfc_code *head, *tail, *new_code;
3735 31085 : match m;
3736 :
3737 31085 : *head_p = head = tail = NULL;
3738 31085 : if (gfc_match_eos () == MATCH_YES)
3739 : return MATCH_YES;
3740 :
3741 47180 : for (;;)
3742 : {
3743 47180 : m = match_io_element (k, &new_code);
3744 47180 : if (m == MATCH_ERROR)
3745 104 : goto cleanup;
3746 47076 : if (m == MATCH_NO)
3747 : goto syntax;
3748 :
3749 47076 : tail = gfc_append_code (tail, new_code);
3750 47076 : if (head == NULL)
3751 30987 : head = new_code;
3752 :
3753 47076 : if (gfc_match_eos () == MATCH_YES)
3754 : break;
3755 16104 : if (gfc_match_char (',') != MATCH_YES)
3756 9 : goto syntax;
3757 : }
3758 :
3759 30972 : *head_p = head;
3760 30972 : return MATCH_YES;
3761 :
3762 9 : syntax:
3763 9 : gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3764 :
3765 113 : cleanup:
3766 113 : gfc_free_statements (head);
3767 113 : return MATCH_ERROR;
3768 : }
3769 :
3770 :
3771 : /* Attach the data transfer end node. */
3772 :
3773 : static void
3774 33104 : terminate_io (gfc_code *io_code)
3775 : {
3776 33104 : gfc_code *c;
3777 :
3778 33104 : if (io_code == NULL)
3779 2167 : io_code = new_st.block;
3780 :
3781 33104 : c = gfc_get_code (EXEC_DT_END);
3782 :
3783 : /* Point to structure that is already there */
3784 33104 : c->ext.dt = new_st.ext.dt;
3785 33104 : gfc_append_code (io_code, c);
3786 33104 : }
3787 :
3788 :
3789 : /* Check the constraints for a data transfer statement. The majority of the
3790 : constraints appearing in 9.4 of the standard appear here.
3791 :
3792 : Tag expressions are already resolved by resolve_tag, which includes
3793 : verifying the type, that they are scalar, and verifying that BT_CHARACTER
3794 : tags are of default kind. */
3795 :
3796 : static bool
3797 32790 : check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3798 : locus *spec_end)
3799 : {
3800 : #define io_constraint(condition, msg, where)\
3801 : if (condition) \
3802 : {\
3803 : if (GFC_LOCUS_IS_SET (*where))\
3804 : gfc_error ((msg), (where));\
3805 : else\
3806 : gfc_error ((msg), spec_end);\
3807 : return false;\
3808 : }
3809 :
3810 32790 : gfc_expr *expr;
3811 32790 : gfc_symbol *sym = NULL;
3812 32790 : bool warn, unformatted;
3813 :
3814 32790 : warn = (dt->err || dt->iostat) ? true : false;
3815 20774 : unformatted = dt->format_expr == NULL && dt->format_label == NULL
3816 36391 : && dt->namelist == NULL;
3817 :
3818 32790 : expr = dt->io_unit;
3819 32790 : if (expr && expr->expr_type == EXPR_VARIABLE
3820 11322 : && expr->ts.type == BT_CHARACTER)
3821 : {
3822 9799 : sym = expr->symtree->n.sym;
3823 :
3824 9799 : io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3825 : "Internal file at %L must not be INTENT(IN)",
3826 9799 : &expr->where);
3827 :
3828 9799 : io_constraint (gfc_has_vector_index (dt->io_unit),
3829 : "Internal file incompatible with vector subscript at %L",
3830 9799 : &expr->where);
3831 :
3832 9799 : io_constraint (dt->rec != NULL,
3833 : "REC tag at %L is incompatible with internal file",
3834 9798 : &dt->rec->where);
3835 :
3836 9798 : io_constraint (dt->pos != NULL,
3837 : "POS tag at %L is incompatible with internal file",
3838 9797 : &dt->pos->where);
3839 :
3840 9797 : io_constraint (unformatted,
3841 : "Unformatted I/O not allowed with internal unit at %L",
3842 9796 : &dt->io_unit->where);
3843 :
3844 9796 : io_constraint (dt->asynchronous != NULL,
3845 : "ASYNCHRONOUS tag at %L not allowed with internal file",
3846 9796 : &dt->asynchronous->where);
3847 :
3848 9796 : if (dt->namelist != NULL)
3849 : {
3850 254 : if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3851 : "namelist", &expr->where))
3852 : return false;
3853 : }
3854 :
3855 9795 : io_constraint (dt->advance != NULL,
3856 : "ADVANCE tag at %L is incompatible with internal file",
3857 : &dt->advance->where);
3858 : }
3859 :
3860 32783 : if (expr && expr->ts.type != BT_CHARACTER)
3861 : {
3862 :
3863 22986 : if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE))
3864 : {
3865 0 : gfc_error ("IO UNIT in %s statement at %L must be "
3866 : "an internal file in a PURE procedure",
3867 : io_kind_name (k), &expr->where);
3868 0 : return false;
3869 : }
3870 :
3871 22986 : if (k == M_READ || k == M_WRITE)
3872 15449 : gfc_unset_implicit_pure (NULL);
3873 : }
3874 :
3875 32785 : if (dt->asynchronous)
3876 : {
3877 206 : int num = -1;
3878 206 : static const char * asynchronous[] = { "YES", "NO", NULL };
3879 :
3880 : /* Note: gfc_reduce_init_expr reports an error if not init-expr. */
3881 206 : if (!gfc_reduce_init_expr (dt->asynchronous))
3882 7 : return false;
3883 :
3884 201 : if (!compare_to_allowed_values
3885 201 : ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3886 : dt->asynchronous->value.character.string,
3887 201 : io_kind_name (k), warn, &dt->asynchronous->where, &num))
3888 : return false;
3889 :
3890 199 : gcc_checking_assert (num != -1);
3891 :
3892 : /* For "YES", mark related symbols as asynchronous. */
3893 199 : if (num == 0)
3894 : {
3895 : /* SIZE variable. */
3896 195 : if (dt->size)
3897 0 : dt->size->symtree->n.sym->attr.asynchronous = 1;
3898 :
3899 : /* Variables in a NAMELIST. */
3900 195 : if (dt->namelist)
3901 4 : for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next)
3902 3 : nl->sym->attr.asynchronous = 1;
3903 :
3904 : /* Variables in an I/O list. */
3905 430 : for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER;
3906 235 : xfer = xfer->next)
3907 : {
3908 235 : gfc_expr *expr = xfer->expr1;
3909 470 : while (expr != NULL && expr->expr_type == EXPR_OP
3910 241 : && expr->value.op.op == INTRINSIC_PARENTHESES)
3911 0 : expr = expr->value.op.op1;
3912 :
3913 235 : if (expr && expr->expr_type == EXPR_VARIABLE)
3914 157 : expr->symtree->n.sym->attr.asynchronous = 1;
3915 : }
3916 : }
3917 : }
3918 :
3919 32778 : if (dt->id)
3920 : {
3921 21 : bool not_yes
3922 21 : = !dt->asynchronous
3923 20 : || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3924 40 : || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3925 32778 : "yes", 3) != 0;
3926 2 : io_constraint (not_yes,
3927 : "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3928 : "specifier", &dt->id->where);
3929 : }
3930 :
3931 32776 : if (dt->decimal)
3932 : {
3933 145 : if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
3934 : "not allowed in Fortran 95", &dt->decimal->where))
3935 : return false;
3936 :
3937 145 : if (dt->decimal->expr_type == EXPR_CONSTANT)
3938 : {
3939 127 : static const char * decimal[] = { "COMMA", "POINT", NULL };
3940 :
3941 127 : if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3942 : dt->decimal->value.character.string,
3943 : io_kind_name (k), warn,
3944 : &dt->decimal->where))
3945 : return false;
3946 :
3947 123 : io_constraint (unformatted,
3948 : "the DECIMAL= specifier at %L must be with an "
3949 : "explicit format expression", &dt->decimal->where);
3950 : }
3951 : }
3952 :
3953 32772 : if (dt->blank)
3954 : {
3955 17 : if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
3956 : "not allowed in Fortran 95", &dt->blank->where))
3957 : return false;
3958 :
3959 17 : if (dt->blank->expr_type == EXPR_CONSTANT)
3960 : {
3961 16 : static const char * blank[] = { "NULL", "ZERO", NULL };
3962 :
3963 :
3964 16 : if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3965 : dt->blank->value.character.string,
3966 : io_kind_name (k), warn,
3967 : &dt->blank->where))
3968 : return false;
3969 :
3970 12 : io_constraint (unformatted,
3971 : "the BLANK= specifier at %L must be with an "
3972 : "explicit format expression", &dt->blank->where);
3973 : }
3974 : }
3975 :
3976 32768 : if (dt->pad)
3977 : {
3978 83 : if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L "
3979 : "not allowed in Fortran 95", &dt->pad->where))
3980 : return false;
3981 :
3982 83 : if (dt->pad->expr_type == EXPR_CONSTANT)
3983 : {
3984 83 : static const char * pad[] = { "YES", "NO", NULL };
3985 :
3986 83 : if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3987 : dt->pad->value.character.string,
3988 : io_kind_name (k), warn,
3989 : &dt->pad->where))
3990 : return false;
3991 :
3992 81 : io_constraint (unformatted,
3993 : "the PAD= specifier at %L must be with an "
3994 : "explicit format expression", &dt->pad->where);
3995 : }
3996 : }
3997 :
3998 32764 : if (dt->round)
3999 : {
4000 317 : if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
4001 : "not allowed in Fortran 95", &dt->round->where))
4002 : return false;
4003 :
4004 317 : if (dt->round->expr_type == EXPR_CONSTANT)
4005 : {
4006 305 : static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
4007 : "COMPATIBLE", "PROCESSOR_DEFINED",
4008 : NULL };
4009 :
4010 305 : if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
4011 : dt->round->value.character.string,
4012 : io_kind_name (k), warn,
4013 : &dt->round->where))
4014 : return false;
4015 : }
4016 : }
4017 :
4018 32760 : if (dt->sign)
4019 : {
4020 : /* When implemented, change the following to use gfc_notify_std F2003.
4021 : if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
4022 : "not allowed in Fortran 95", &dt->sign->where) == false)
4023 : return false; */
4024 :
4025 17 : if (dt->sign->expr_type == EXPR_CONSTANT)
4026 : {
4027 16 : static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
4028 : NULL };
4029 :
4030 16 : if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
4031 : dt->sign->value.character.string,
4032 : io_kind_name (k), warn, &dt->sign->where))
4033 : return false;
4034 :
4035 12 : io_constraint (unformatted,
4036 : "SIGN= specifier at %L must be with an "
4037 12 : "explicit format expression", &dt->sign->where);
4038 :
4039 12 : io_constraint (k == M_READ,
4040 : "SIGN= specifier at %L not allowed in a "
4041 : "READ statement", &dt->sign->where);
4042 : }
4043 : }
4044 :
4045 32756 : if (dt->delim)
4046 : {
4047 7 : if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L "
4048 : "not allowed in Fortran 95", &dt->delim->where))
4049 : return false;
4050 :
4051 6 : if (dt->delim->expr_type == EXPR_CONSTANT)
4052 : {
4053 6 : static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
4054 :
4055 6 : if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
4056 : dt->delim->value.character.string,
4057 : io_kind_name (k), warn,
4058 : &dt->delim->where))
4059 : return false;
4060 :
4061 2 : io_constraint (k == M_READ,
4062 : "DELIM= specifier at %L not allowed in a "
4063 2 : "READ statement", &dt->delim->where);
4064 :
4065 2 : io_constraint (dt->format_label != &format_asterisk
4066 : && dt->namelist == NULL,
4067 : "DELIM= specifier at %L must have FMT=*",
4068 2 : &dt->delim->where);
4069 :
4070 2 : io_constraint (unformatted && dt->namelist == NULL,
4071 : "DELIM= specifier at %L must be with FMT=* or "
4072 : "NML= specifier", &dt->delim->where);
4073 : }
4074 : }
4075 :
4076 32751 : if (dt->namelist)
4077 : {
4078 1197 : io_constraint (io_code && dt->namelist,
4079 : "NAMELIST cannot be followed by IO-list at %L",
4080 1196 : &io_code->loc);
4081 :
4082 1196 : io_constraint (dt->format_expr,
4083 : "IO spec-list cannot contain both NAMELIST group name "
4084 : "and format specification at %L",
4085 1195 : &dt->format_expr->where);
4086 :
4087 1195 : io_constraint (dt->format_label,
4088 : "IO spec-list cannot contain both NAMELIST group name "
4089 1194 : "and format label at %L", spec_end);
4090 :
4091 1194 : io_constraint (dt->rec,
4092 : "NAMELIST IO is not allowed with a REC= specifier "
4093 1194 : "at %L", &dt->rec->where);
4094 :
4095 1194 : io_constraint (dt->advance,
4096 : "NAMELIST IO is not allowed with a ADVANCE= specifier "
4097 : "at %L", &dt->advance->where);
4098 : }
4099 :
4100 32747 : if (dt->rec)
4101 : {
4102 499 : io_constraint (dt->end,
4103 : "An END tag is not allowed with a "
4104 498 : "REC= specifier at %L", &dt->end_where);
4105 :
4106 498 : io_constraint (dt->format_label == &format_asterisk,
4107 : "FMT=* is not allowed with a REC= specifier "
4108 497 : "at %L", spec_end);
4109 :
4110 497 : io_constraint (dt->pos,
4111 : "POS= is not allowed with REC= specifier "
4112 : "at %L", &dt->pos->where);
4113 : }
4114 :
4115 32743 : if (dt->advance)
4116 : {
4117 373 : int not_yes, not_no;
4118 373 : expr = dt->advance;
4119 :
4120 373 : io_constraint (dt->format_label == &format_asterisk,
4121 : "List directed format(*) is not allowed with a "
4122 373 : "ADVANCE= specifier at %L.", &expr->where);
4123 :
4124 373 : io_constraint (unformatted,
4125 : "the ADVANCE= specifier at %L must appear with an "
4126 372 : "explicit format expression", &expr->where);
4127 :
4128 372 : if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
4129 : {
4130 353 : const gfc_char_t *advance = expr->value.character.string;
4131 353 : not_no = gfc_wide_strlen (advance) != 2
4132 353 : || gfc_wide_strncasecmp (advance, "no", 2) != 0;
4133 353 : not_yes = gfc_wide_strlen (advance) != 3
4134 353 : || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
4135 353 : }
4136 : else
4137 : {
4138 : not_no = 0;
4139 : not_yes = 0;
4140 : }
4141 :
4142 372 : io_constraint (not_no && not_yes,
4143 : "ADVANCE= specifier at %L must have value = "
4144 368 : "YES or NO.", &expr->where);
4145 :
4146 368 : io_constraint (dt->size && not_no && k == M_READ,
4147 : "SIZE tag at %L requires an ADVANCE = %<NO%>",
4148 367 : &dt->size->where);
4149 :
4150 367 : io_constraint (dt->eor && not_no && k == M_READ,
4151 : "EOR tag at %L requires an ADVANCE = %<NO%>",
4152 : &dt->eor_where);
4153 : }
4154 :
4155 32736 : if (k != M_READ)
4156 : {
4157 26582 : io_constraint (dt->end, "END tag not allowed with output at %L",
4158 26581 : &dt->end_where);
4159 :
4160 26581 : io_constraint (dt->eor, "EOR tag not allowed with output at %L",
4161 26579 : &dt->eor_where);
4162 :
4163 26579 : io_constraint (dt->blank,
4164 : "BLANK= specifier not allowed with output at %L",
4165 26579 : &dt->blank->where);
4166 :
4167 26579 : io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
4168 26579 : &dt->pad->where);
4169 :
4170 26579 : io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
4171 : &dt->size->where);
4172 : }
4173 : else
4174 : {
4175 6154 : io_constraint (dt->size && dt->advance == NULL,
4176 : "SIZE tag at %L requires an ADVANCE tag",
4177 6154 : &dt->size->where);
4178 :
4179 6154 : io_constraint (dt->eor && dt->advance == NULL,
4180 : "EOR tag at %L requires an ADVANCE tag",
4181 : &dt->eor_where);
4182 : }
4183 :
4184 : return true;
4185 : #undef io_constraint
4186 : }
4187 :
4188 :
4189 : /* Match a READ, WRITE or PRINT statement. */
4190 :
4191 : static match
4192 33184 : match_io (io_kind k)
4193 : {
4194 33184 : char name[GFC_MAX_SYMBOL_LEN + 1];
4195 33184 : gfc_code *io_code;
4196 33184 : gfc_symbol *sym;
4197 33184 : int comma_flag;
4198 33184 : locus where;
4199 33184 : locus control;
4200 33184 : gfc_dt *dt;
4201 33184 : match m;
4202 :
4203 33184 : where = gfc_current_locus;
4204 33184 : comma_flag = 0;
4205 33184 : current_dt = dt = XCNEW (gfc_dt);
4206 33184 : m = gfc_match_char ('(');
4207 33184 : if (m == MATCH_NO)
4208 : {
4209 7683 : where = gfc_current_locus;
4210 7683 : if (k == M_WRITE)
4211 0 : goto syntax;
4212 7683 : else if (k == M_PRINT)
4213 : {
4214 : /* Treat the non-standard case of PRINT namelist. */
4215 7389 : if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
4216 14822 : && gfc_match_name (name) == MATCH_YES)
4217 : {
4218 131 : gfc_find_symbol (name, NULL, 1, &sym);
4219 131 : if (sym && sym->attr.flavor == FL_NAMELIST)
4220 : {
4221 11 : if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
4222 : "%C is an extension"))
4223 : {
4224 2 : m = MATCH_ERROR;
4225 2 : goto cleanup;
4226 : }
4227 :
4228 9 : dt->io_unit = default_unit (k);
4229 9 : dt->namelist = sym;
4230 9 : goto get_io_list;
4231 : }
4232 : else
4233 120 : gfc_current_locus = where;
4234 : }
4235 :
4236 7658 : if (gfc_match_char ('*') == MATCH_YES
4237 7658 : && gfc_match_char(',') == MATCH_YES)
4238 : {
4239 6864 : locus where2 = gfc_current_locus;
4240 6864 : if (gfc_match_eos () == MATCH_YES)
4241 : {
4242 1 : gfc_current_locus = where2;
4243 1 : gfc_error ("Comma after * at %C not allowed without I/O list");
4244 1 : m = MATCH_ERROR;
4245 1 : goto cleanup;
4246 : }
4247 : else
4248 6863 : gfc_current_locus = where;
4249 : }
4250 : else
4251 794 : gfc_current_locus = where;
4252 : }
4253 :
4254 7671 : if (gfc_current_form == FORM_FREE)
4255 : {
4256 7393 : char c = gfc_peek_ascii_char ();
4257 :
4258 : /* Issue a warning for an invalid tab in 'print<tab>*'. After
4259 : the warning is issued, consume any other whitespace and check
4260 : that the next char is an *, ', or ". */
4261 7393 : if (c == '\t')
4262 : {
4263 2 : gfc_gobble_whitespace ();
4264 2 : c = gfc_peek_ascii_char ();
4265 2 : if (c != '*' && c != '\'' && c != '"')
4266 : {
4267 0 : m = MATCH_NO;
4268 0 : goto cleanup;
4269 : }
4270 : }
4271 7391 : else if (c != ' ' && c != '*' && c != '\'' && c != '"')
4272 : {
4273 2 : m = MATCH_NO;
4274 2 : goto cleanup;
4275 : }
4276 : }
4277 :
4278 7669 : m = match_dt_format (dt);
4279 7669 : if (m == MATCH_ERROR)
4280 0 : goto cleanup;
4281 7669 : if (m == MATCH_NO)
4282 4 : goto syntax;
4283 :
4284 7665 : comma_flag = 1;
4285 7665 : dt->io_unit = default_unit (k);
4286 7665 : goto get_io_list;
4287 : }
4288 : else
4289 : {
4290 : /* Before issuing an error for a malformed 'print (1,*)' type of
4291 : error, check for a default-char-expr of the form ('(I0)'). */
4292 25501 : if (m == MATCH_YES)
4293 : {
4294 25501 : control = gfc_current_locus;
4295 25501 : if (k == M_PRINT)
4296 : {
4297 : /* Reset current locus to get the initial '(' in an expression. */
4298 10 : gfc_current_locus = where;
4299 10 : dt->format_expr = NULL;
4300 10 : m = match_dt_format (dt);
4301 :
4302 10 : if (m == MATCH_ERROR)
4303 0 : goto cleanup;
4304 10 : if (m == MATCH_NO || dt->format_expr == NULL)
4305 3 : goto syntax;
4306 :
4307 7 : comma_flag = 1;
4308 7 : dt->io_unit = default_unit (k);
4309 7 : goto get_io_list;
4310 : }
4311 25491 : if (k == M_READ)
4312 : {
4313 : /* Commit any pending symbols now so that when we undo
4314 : symbols later we wont lose them. */
4315 6273 : gfc_commit_symbols ();
4316 : /* Reset current locus to get the initial '(' in an expression. */
4317 6273 : gfc_current_locus = where;
4318 6273 : dt->format_expr = NULL;
4319 6273 : m = gfc_match_expr (&dt->format_expr);
4320 6273 : if (m == MATCH_YES)
4321 : {
4322 545 : if (dt->format_expr
4323 545 : && dt->format_expr->ts.type == BT_CHARACTER)
4324 : {
4325 3 : comma_flag = 1;
4326 3 : dt->io_unit = default_unit (k);
4327 3 : goto get_io_list;
4328 : }
4329 : else
4330 : {
4331 542 : gfc_free_expr (dt->format_expr);
4332 542 : dt->format_expr = NULL;
4333 542 : gfc_current_locus = control;
4334 : }
4335 : }
4336 : else
4337 : {
4338 5728 : gfc_clear_error ();
4339 5728 : gfc_undo_symbols ();
4340 5728 : gfc_free_expr (dt->format_expr);
4341 5728 : dt->format_expr = NULL;
4342 5728 : gfc_current_locus = control;
4343 : }
4344 : }
4345 : }
4346 : }
4347 :
4348 : /* Match a control list */
4349 25488 : if (match_dt_element (k, dt) == MATCH_YES)
4350 1213 : goto next;
4351 24275 : if (match_dt_unit (k, dt) != MATCH_YES)
4352 0 : goto loop;
4353 :
4354 24275 : if (gfc_match_char (')') == MATCH_YES)
4355 1479 : goto get_io_list;
4356 22796 : if (gfc_match_char (',') != MATCH_YES)
4357 0 : goto syntax;
4358 :
4359 22796 : m = match_dt_element (k, dt);
4360 22796 : if (m == MATCH_YES)
4361 2660 : goto next;
4362 20136 : if (m == MATCH_ERROR)
4363 0 : goto cleanup;
4364 :
4365 20136 : m = match_dt_format (dt);
4366 20136 : if (m == MATCH_YES)
4367 19709 : goto next;
4368 427 : if (m == MATCH_ERROR)
4369 7 : goto cleanup;
4370 :
4371 420 : where = gfc_current_locus;
4372 :
4373 420 : m = gfc_match_name (name);
4374 420 : if (m == MATCH_YES)
4375 : {
4376 420 : gfc_find_symbol (name, NULL, 1, &sym);
4377 420 : if (sym && sym->attr.flavor == FL_NAMELIST)
4378 : {
4379 420 : dt->namelist = sym;
4380 420 : if (k == M_READ && check_namelist (sym))
4381 : {
4382 1 : m = MATCH_ERROR;
4383 1 : goto cleanup;
4384 : }
4385 419 : goto next;
4386 : }
4387 : }
4388 :
4389 0 : gfc_current_locus = where;
4390 :
4391 0 : goto loop; /* No matches, try regular elements */
4392 :
4393 24001 : next:
4394 24001 : if (gfc_match_char (')') == MATCH_YES)
4395 19814 : goto get_io_list;
4396 4187 : if (gfc_match_char (',') != MATCH_YES)
4397 0 : goto syntax;
4398 :
4399 4187 : loop:
4400 5295 : for (;;)
4401 : {
4402 5295 : m = match_dt_element (k, dt);
4403 5295 : if (m == MATCH_NO)
4404 0 : goto syntax;
4405 5295 : if (m == MATCH_ERROR)
4406 4 : goto cleanup;
4407 :
4408 5291 : if (gfc_match_char (')') == MATCH_YES)
4409 : break;
4410 1108 : if (gfc_match_char (',') != MATCH_YES)
4411 0 : goto syntax;
4412 : }
4413 :
4414 4183 : get_io_list:
4415 :
4416 : /* Save the IO kind for later use. */
4417 33160 : dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
4418 :
4419 : /* Optional leading comma (non-standard). We use a gfc_expr structure here
4420 : to save the locus. This is used later when resolving transfer statements
4421 : that might have a format expression without unit number. */
4422 33160 : if (!comma_flag && gfc_match_char (',') == MATCH_YES)
4423 87 : dt->extra_comma = dt->dt_io_kind;
4424 :
4425 33160 : io_code = NULL;
4426 33160 : if (gfc_match_eos () != MATCH_YES)
4427 : {
4428 30992 : if (comma_flag && gfc_match_char (',') != MATCH_YES)
4429 : {
4430 0 : gfc_error ("Expected comma in I/O list at %C");
4431 0 : m = MATCH_ERROR;
4432 0 : goto cleanup;
4433 : }
4434 :
4435 30992 : m = match_io_list (k, &io_code);
4436 30992 : if (m == MATCH_ERROR)
4437 113 : goto cleanup;
4438 : if (m == MATCH_NO)
4439 : goto syntax;
4440 : }
4441 :
4442 : /* See if we want to use defaults for missing exponents in real transfers
4443 : and other DEC runtime extensions. */
4444 33047 : if (flag_dec_format_defaults)
4445 484 : dt->dec_ext = 1;
4446 :
4447 : /* Check the format string now. */
4448 33047 : if (dt->format_expr
4449 33047 : && (!gfc_simplify_expr (dt->format_expr, 0)
4450 12087 : || !check_format_string (dt->format_expr, k == M_READ)))
4451 35 : return MATCH_ERROR;
4452 :
4453 33012 : new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
4454 33012 : new_st.ext.dt = dt;
4455 33012 : new_st.block = gfc_get_code (new_st.op);
4456 33012 : new_st.block->next = io_code;
4457 :
4458 33012 : terminate_io (io_code);
4459 :
4460 33012 : return MATCH_YES;
4461 :
4462 7 : syntax:
4463 7 : gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
4464 7 : m = MATCH_ERROR;
4465 :
4466 137 : cleanup:
4467 137 : gfc_free_dt (dt);
4468 137 : return m;
4469 : }
4470 :
4471 :
4472 : match
4473 6287 : gfc_match_read (void)
4474 : {
4475 6287 : return match_io (M_READ);
4476 : }
4477 :
4478 :
4479 : match
4480 19218 : gfc_match_write (void)
4481 : {
4482 19218 : return match_io (M_WRITE);
4483 : }
4484 :
4485 :
4486 : match
4487 7679 : gfc_match_print (void)
4488 : {
4489 7679 : match m;
4490 :
4491 7679 : m = match_io (M_PRINT);
4492 7679 : if (m != MATCH_YES)
4493 : return m;
4494 :
4495 7554 : if (gfc_pure (NULL))
4496 : {
4497 0 : gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4498 0 : return MATCH_ERROR;
4499 : }
4500 :
4501 7554 : gfc_unset_implicit_pure (NULL);
4502 :
4503 7554 : return MATCH_YES;
4504 : }
4505 :
4506 :
4507 : /* Free a gfc_inquire structure. */
4508 :
4509 : void
4510 844 : gfc_free_inquire (gfc_inquire *inquire)
4511 : {
4512 :
4513 844 : if (inquire == NULL)
4514 : return;
4515 :
4516 844 : gfc_free_expr (inquire->unit);
4517 844 : gfc_free_expr (inquire->file);
4518 844 : gfc_free_expr (inquire->iomsg);
4519 844 : gfc_free_expr (inquire->iostat);
4520 844 : gfc_free_expr (inquire->exist);
4521 844 : gfc_free_expr (inquire->opened);
4522 844 : gfc_free_expr (inquire->number);
4523 844 : gfc_free_expr (inquire->named);
4524 844 : gfc_free_expr (inquire->name);
4525 844 : gfc_free_expr (inquire->access);
4526 844 : gfc_free_expr (inquire->sequential);
4527 844 : gfc_free_expr (inquire->direct);
4528 844 : gfc_free_expr (inquire->form);
4529 844 : gfc_free_expr (inquire->formatted);
4530 844 : gfc_free_expr (inquire->unformatted);
4531 844 : gfc_free_expr (inquire->recl);
4532 844 : gfc_free_expr (inquire->nextrec);
4533 844 : gfc_free_expr (inquire->blank);
4534 844 : gfc_free_expr (inquire->position);
4535 844 : gfc_free_expr (inquire->action);
4536 844 : gfc_free_expr (inquire->read);
4537 844 : gfc_free_expr (inquire->write);
4538 844 : gfc_free_expr (inquire->readwrite);
4539 844 : gfc_free_expr (inquire->delim);
4540 844 : gfc_free_expr (inquire->encoding);
4541 844 : gfc_free_expr (inquire->pad);
4542 844 : gfc_free_expr (inquire->iolength);
4543 844 : gfc_free_expr (inquire->convert);
4544 844 : gfc_free_expr (inquire->strm_pos);
4545 844 : gfc_free_expr (inquire->asynchronous);
4546 844 : gfc_free_expr (inquire->decimal);
4547 844 : gfc_free_expr (inquire->pending);
4548 844 : gfc_free_expr (inquire->id);
4549 844 : gfc_free_expr (inquire->sign);
4550 844 : gfc_free_expr (inquire->size);
4551 844 : gfc_free_expr (inquire->round);
4552 844 : gfc_free_expr (inquire->share);
4553 844 : gfc_free_expr (inquire->cc);
4554 844 : free (inquire);
4555 : }
4556 :
4557 :
4558 : /* Match an element of an INQUIRE statement. */
4559 :
4560 : #define RETM if (m != MATCH_NO) return m;
4561 :
4562 : static match
4563 2603 : match_inquire_element (gfc_inquire *inquire)
4564 : {
4565 2603 : match m;
4566 :
4567 2603 : m = match_etag (&tag_unit, &inquire->unit);
4568 2603 : RETM m = match_etag (&tag_file, &inquire->file);
4569 2270 : RETM m = match_ltag (&tag_err, &inquire->err);
4570 2059 : RETM m = match_etag (&tag_iomsg, &inquire->iomsg);
4571 2052 : RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
4572 2028 : RETM m = match_vtag (&tag_exist, &inquire->exist);
4573 1980 : RETM m = match_vtag (&tag_opened, &inquire->opened);
4574 1838 : RETM m = match_vtag (&tag_named, &inquire->named);
4575 1686 : RETM m = match_vtag (&tag_name, &inquire->name);
4576 1663 : RETM m = match_out_tag (&tag_number, &inquire->number);
4577 1636 : RETM m = match_vtag (&tag_s_access, &inquire->access);
4578 1549 : RETM m = match_vtag (&tag_sequential, &inquire->sequential);
4579 1399 : RETM m = match_vtag (&tag_direct, &inquire->direct);
4580 1360 : RETM m = match_vtag (&tag_s_form, &inquire->form);
4581 1249 : RETM m = match_vtag (&tag_formatted, &inquire->formatted);
4582 1234 : RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
4583 1188 : RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
4584 1149 : RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
4585 1090 : RETM m = match_vtag (&tag_s_blank, &inquire->blank);
4586 1028 : RETM m = match_vtag (&tag_s_position, &inquire->position);
4587 1004 : RETM m = match_vtag (&tag_s_action, &inquire->action);
4588 947 : RETM m = match_vtag (&tag_read, &inquire->read);
4589 925 : RETM m = match_vtag (&tag_write, &inquire->write);
4590 892 : RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
4591 859 : RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
4592 826 : RETM m = match_vtag (&tag_s_delim, &inquire->delim);
4593 799 : RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
4594 759 : RETM m = match_out_tag (&tag_size, &inquire->size);
4595 740 : RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
4596 697 : RETM m = match_vtag (&tag_s_round, &inquire->round);
4597 677 : RETM m = match_vtag (&tag_s_sign, &inquire->sign);
4598 658 : RETM m = match_vtag (&tag_s_pad, &inquire->pad);
4599 639 : RETM m = match_out_tag (&tag_iolength, &inquire->iolength);
4600 600 : RETM m = match_vtag (&tag_convert, &inquire->convert);
4601 507 : RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
4602 495 : RETM m = match_vtag (&tag_pending, &inquire->pending);
4603 387 : RETM m = match_etag (&tag_id, &inquire->id);
4604 367 : RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
4605 356 : RETM m = match_dec_vtag (&tag_v_share, &inquire->share);
4606 314 : RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc);
4607 307 : RETM return MATCH_NO;
4608 : }
4609 :
4610 : #undef RETM
4611 :
4612 :
4613 : match
4614 936 : gfc_match_inquire (void)
4615 : {
4616 936 : gfc_inquire *inquire;
4617 936 : gfc_code *code;
4618 936 : match m;
4619 936 : locus loc;
4620 :
4621 936 : m = gfc_match_char ('(');
4622 936 : if (m == MATCH_NO)
4623 : return m;
4624 :
4625 936 : inquire = XCNEW (gfc_inquire);
4626 :
4627 936 : loc = gfc_current_locus;
4628 :
4629 936 : m = match_inquire_element (inquire);
4630 936 : if (m == MATCH_ERROR)
4631 0 : goto cleanup;
4632 936 : if (m == MATCH_NO)
4633 : {
4634 300 : m = gfc_match_expr (&inquire->unit);
4635 300 : if (m == MATCH_ERROR)
4636 0 : goto cleanup;
4637 300 : if (m == MATCH_NO)
4638 0 : goto syntax;
4639 : }
4640 :
4641 : /* See if we have the IOLENGTH form of the inquire statement. */
4642 936 : if (inquire->iolength != NULL)
4643 : {
4644 93 : if (gfc_match_char (')') != MATCH_YES)
4645 0 : goto syntax;
4646 :
4647 93 : m = match_io_list (M_INQUIRE, &code);
4648 93 : if (m == MATCH_ERROR)
4649 0 : goto cleanup;
4650 93 : if (m == MATCH_NO)
4651 : goto syntax;
4652 :
4653 246 : for (gfc_code *c = code; c; c = c->next)
4654 154 : if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION
4655 2 : && c->expr1->symtree && c->expr1->symtree->n.sym->attr.function
4656 2 : && !c->expr1->symtree->n.sym->attr.external
4657 1 : && strcmp (c->expr1->symtree->name, "null") == 0)
4658 : {
4659 1 : gfc_error ("NULL() near %L cannot appear in INQUIRE statement",
4660 : &c->expr1->where);
4661 1 : goto cleanup;
4662 : }
4663 :
4664 92 : new_st.op = EXEC_IOLENGTH;
4665 92 : new_st.expr1 = inquire->iolength;
4666 92 : new_st.ext.inquire = inquire;
4667 :
4668 92 : if (gfc_pure (NULL))
4669 : {
4670 0 : gfc_free_statements (code);
4671 0 : gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4672 0 : return MATCH_ERROR;
4673 : }
4674 :
4675 92 : gfc_unset_implicit_pure (NULL);
4676 :
4677 92 : new_st.block = gfc_get_code (EXEC_IOLENGTH);
4678 92 : terminate_io (code);
4679 92 : new_st.block->next = code;
4680 92 : return MATCH_YES;
4681 : }
4682 :
4683 : /* At this point, we have the non-IOLENGTH inquire statement. */
4684 2508 : for (;;)
4685 : {
4686 2508 : if (gfc_match_char (')') == MATCH_YES)
4687 : break;
4688 1667 : if (gfc_match_char (',') != MATCH_YES)
4689 0 : goto syntax;
4690 :
4691 1667 : m = match_inquire_element (inquire);
4692 1667 : if (m == MATCH_ERROR)
4693 2 : goto cleanup;
4694 1665 : if (m == MATCH_NO)
4695 0 : goto syntax;
4696 :
4697 1665 : if (inquire->iolength != NULL)
4698 : {
4699 0 : gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4700 0 : goto cleanup;
4701 : }
4702 : }
4703 :
4704 841 : if (gfc_match_eos () != MATCH_YES)
4705 0 : goto syntax;
4706 :
4707 841 : if (inquire->unit != NULL && inquire->file != NULL)
4708 : {
4709 2 : gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4710 : "UNIT specifiers", &loc);
4711 2 : goto cleanup;
4712 : }
4713 :
4714 839 : if (inquire->unit == NULL && inquire->file == NULL)
4715 : {
4716 1 : gfc_error ("INQUIRE statement at %L requires either FILE or "
4717 : "UNIT specifier", &loc);
4718 1 : goto cleanup;
4719 : }
4720 :
4721 838 : if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT
4722 522 : && inquire->unit->ts.type == BT_INTEGER
4723 522 : && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4)
4724 521 : || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT)))
4725 : {
4726 2 : gfc_error ("UNIT number in INQUIRE statement at %L cannot "
4727 : "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer));
4728 2 : goto cleanup;
4729 : }
4730 :
4731 836 : if (gfc_pure (NULL))
4732 : {
4733 0 : gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4734 0 : goto cleanup;
4735 : }
4736 :
4737 836 : gfc_unset_implicit_pure (NULL);
4738 :
4739 836 : if (inquire->id != NULL && inquire->pending == NULL)
4740 : {
4741 0 : gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4742 : "the ID= specifier", &loc);
4743 0 : goto cleanup;
4744 : }
4745 :
4746 836 : new_st.op = EXEC_INQUIRE;
4747 836 : new_st.ext.inquire = inquire;
4748 836 : return MATCH_YES;
4749 :
4750 0 : syntax:
4751 0 : gfc_syntax_error (ST_INQUIRE);
4752 :
4753 8 : cleanup:
4754 8 : gfc_free_inquire (inquire);
4755 8 : return MATCH_ERROR;
4756 : }
4757 :
4758 :
4759 : /* Resolve everything in a gfc_inquire structure. */
4760 :
4761 : bool
4762 928 : gfc_resolve_inquire (gfc_inquire *inquire)
4763 : {
4764 928 : RESOLVE_TAG (&tag_unit, inquire->unit);
4765 928 : RESOLVE_TAG (&tag_file, inquire->file);
4766 927 : RESOLVE_TAG (&tag_id, inquire->id);
4767 :
4768 : /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4769 : contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4770 : #define INQUIRE_RESOLVE_TAG(tag, expr) \
4771 : RESOLVE_TAG (tag, expr); \
4772 : if (expr) \
4773 : { \
4774 : char context[64]; \
4775 : sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4776 : if (gfc_check_vardef_context ((expr), false, false, false, \
4777 : context) == false) \
4778 : return false; \
4779 : }
4780 927 : INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4781 915 : INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4782 914 : INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4783 912 : INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4784 910 : INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4785 908 : INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4786 906 : INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4787 905 : INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4788 904 : INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4789 903 : INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4790 902 : INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4791 901 : INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4792 899 : INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4793 898 : INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4794 897 : INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4795 896 : INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4796 895 : INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4797 894 : INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4798 893 : INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4799 892 : INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4800 891 : INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4801 890 : INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4802 889 : INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4803 888 : INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4804 886 : INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4805 885 : INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4806 883 : INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4807 883 : INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4808 883 : INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4809 882 : INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4810 881 : INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4811 881 : INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4812 879 : INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4813 879 : INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4814 878 : INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
4815 878 : INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share);
4816 878 : INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc);
4817 : #undef INQUIRE_RESOLVE_TAG
4818 :
4819 878 : if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4820 : return false;
4821 :
4822 : return true;
4823 : }
4824 :
4825 :
4826 : void
4827 89 : gfc_free_wait (gfc_wait *wait)
4828 : {
4829 89 : if (wait == NULL)
4830 : return;
4831 :
4832 89 : gfc_free_expr (wait->unit);
4833 89 : gfc_free_expr (wait->iostat);
4834 89 : gfc_free_expr (wait->iomsg);
4835 89 : gfc_free_expr (wait->id);
4836 89 : free (wait);
4837 : }
4838 :
4839 :
4840 : bool
4841 89 : gfc_resolve_wait (gfc_wait *wait)
4842 : {
4843 89 : RESOLVE_TAG (&tag_unit, wait->unit);
4844 89 : RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4845 74 : RESOLVE_TAG (&tag_iostat, wait->iostat);
4846 74 : RESOLVE_TAG (&tag_id, wait->id);
4847 :
4848 74 : if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4849 : return false;
4850 :
4851 74 : if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4852 : return false;
4853 :
4854 : return true;
4855 : }
4856 :
4857 : /* Match an element of a WAIT statement. */
4858 :
4859 : #define RETM if (m != MATCH_NO) return m;
4860 :
4861 : static match
4862 166 : match_wait_element (gfc_wait *wait)
4863 : {
4864 166 : match m;
4865 :
4866 166 : m = match_etag (&tag_unit, &wait->unit);
4867 166 : RETM m = match_ltag (&tag_err, &wait->err);
4868 153 : RETM m = match_ltag (&tag_end, &wait->end);
4869 146 : RETM m = match_ltag (&tag_eor, &wait->eor);
4870 139 : RETM m = match_etag (&tag_iomsg, &wait->iomsg);
4871 139 : RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4872 110 : RETM m = match_etag (&tag_id, &wait->id);
4873 89 : RETM return MATCH_NO;
4874 : }
4875 :
4876 : #undef RETM
4877 :
4878 :
4879 : match
4880 89 : gfc_match_wait (void)
4881 : {
4882 89 : gfc_wait *wait;
4883 89 : match m;
4884 :
4885 89 : m = gfc_match_char ('(');
4886 89 : if (m == MATCH_NO)
4887 : return m;
4888 :
4889 89 : wait = XCNEW (gfc_wait);
4890 :
4891 89 : m = match_wait_element (wait);
4892 89 : if (m == MATCH_ERROR)
4893 0 : goto cleanup;
4894 89 : if (m == MATCH_NO)
4895 : {
4896 76 : m = gfc_match_expr (&wait->unit);
4897 76 : if (m == MATCH_ERROR)
4898 0 : goto cleanup;
4899 76 : if (m == MATCH_NO)
4900 0 : goto syntax;
4901 : }
4902 :
4903 166 : for (;;)
4904 : {
4905 166 : if (gfc_match_char (')') == MATCH_YES)
4906 : break;
4907 77 : if (gfc_match_char (',') != MATCH_YES)
4908 0 : goto syntax;
4909 :
4910 77 : m = match_wait_element (wait);
4911 77 : if (m == MATCH_ERROR)
4912 0 : goto cleanup;
4913 77 : if (m == MATCH_NO)
4914 0 : goto syntax;
4915 : }
4916 :
4917 89 : if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4918 : "not allowed in Fortran 95"))
4919 0 : goto cleanup;
4920 :
4921 89 : if (gfc_pure (NULL))
4922 : {
4923 0 : gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4924 0 : goto cleanup;
4925 : }
4926 :
4927 89 : gfc_unset_implicit_pure (NULL);
4928 :
4929 89 : new_st.op = EXEC_WAIT;
4930 89 : new_st.ext.wait = wait;
4931 :
4932 89 : return MATCH_YES;
4933 :
4934 0 : syntax:
4935 0 : gfc_syntax_error (ST_WAIT);
4936 :
4937 0 : cleanup:
4938 0 : gfc_free_wait (wait);
4939 0 : return MATCH_ERROR;
4940 : }
|
