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