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