]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/io.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update copyright years in gcc/
[thirdparty/gcc.git] / gcc / fortran / io.c
CommitLineData
6de9cd9a 1/* Deal with I/O statements & related stuff.
23a5b65a 2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Andy Vaught
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
d234d788 9Software Foundation; either version 3, or (at your option) any later
9fc4d79b 10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
d234d788
NC		 18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
6de9cd9a
DN		 20
21#include "config.h"
22#include "system.h"
953bee7c 23#include "coretypes.h"
6de9cd9a 24#include "flags.h"
6de9cd9a
DN		 25#include "gfortran.h"
26#include "match.h"
27#include "parse.h"
28
b251af97
SK		 29gfc_st_label
30format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
31 0, {NULL, NULL}};
6de9cd9a
DN		 32
33typedef struct
34{
9b8d1901 35 const char *name, *spec, *value;
6de9cd9a
DN		 36 bt type;
37}
38io_tag;
39
40static const io_tag
9ad55c33
JD		 41 tag_file = {"FILE", " file =", " %e", BT_CHARACTER },
42 tag_status = {"STATUS", " status =", " %e", BT_CHARACTER},
9b8d1901
TS		 43 tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER},
44 tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER},
45 tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER},
46 tag_e_blank = {"BLANK", " blank =", " %e", BT_CHARACTER},
47 tag_e_position = {"POSITION", " position =", " %e", BT_CHARACTER},
48 tag_e_action = {"ACTION", " action =", " %e", BT_CHARACTER},
49 tag_e_delim = {"DELIM", " delim =", " %e", BT_CHARACTER},
50 tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER},
51 tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
52 tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER},
d06b3496 53 tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
9b8d1901
TS		 54 tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER},
55 tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER},
56 tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER},
57 tag_advance = {"ADVANCE", " advance =", " %e", BT_CHARACTER},
58 tag_rec = {"REC", " rec =", " %e", BT_INTEGER},
59 tag_spos = {"POSITION", " pos =", " %e", BT_INTEGER},
60 tag_format = {"FORMAT", NULL, NULL, BT_CHARACTER},
61 tag_iomsg = {"IOMSG", " iomsg =", " %e", BT_CHARACTER},
62 tag_iostat = {"IOSTAT", " iostat =", " %v", BT_INTEGER},
63 tag_size = {"SIZE", " size =", " %v", BT_INTEGER},
64 tag_exist = {"EXIST", " exist =", " %v", BT_LOGICAL},
65 tag_opened = {"OPENED", " opened =", " %v", BT_LOGICAL},
66 tag_named = {"NAMED", " named =", " %v", BT_LOGICAL},
67 tag_name = {"NAME", " name =", " %v", BT_CHARACTER},
68 tag_number = {"NUMBER", " number =", " %v", BT_INTEGER},
69 tag_s_access = {"ACCESS", " access =", " %v", BT_CHARACTER},
70 tag_sequential = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER},
71 tag_direct = {"DIRECT", " direct =", " %v", BT_CHARACTER},
72 tag_s_form = {"FORM", " form =", " %v", BT_CHARACTER},
73 tag_formatted = {"FORMATTED", " formatted =", " %v", BT_CHARACTER},
74 tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER},
75 tag_s_recl = {"RECL", " recl =", " %v", BT_INTEGER},
76 tag_nextrec = {"NEXTREC", " nextrec =", " %v", BT_INTEGER},
77 tag_s_blank = {"BLANK", " blank =", " %v", BT_CHARACTER},
78 tag_s_position = {"POSITION", " position =", " %v", BT_CHARACTER},
79 tag_s_action = {"ACTION", " action =", " %v", BT_CHARACTER},
80 tag_read = {"READ", " read =", " %v", BT_CHARACTER},
81 tag_write = {"WRITE", " write =", " %v", BT_CHARACTER},
82 tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
83 tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER},
84 tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER},
d06b3496
JD		 85 tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
86 tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER},
87 tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
88 tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER},
89 tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER},
9b8d1901
TS		 90 tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
91 tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER},
92 tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER},
93 tag_err = {"ERR", " err =", " %l", BT_UNKNOWN},
94 tag_end = {"END", " end =", " %l", BT_UNKNOWN},
95 tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN},
d06b3496 96 tag_id = {"ID", " id =", " %v", BT_INTEGER},
9ad55c33 97 tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL},
93e8af19
JD		 98 tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER},
99 tag_s_iqstream = {"STREAM", " stream =", " %v", BT_CHARACTER};
6de9cd9a
DN		 100
101static gfc_dt *current_dt;
102
524af0d6 103#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
6de9cd9a
DN		 104
105
106/**************** Fortran 95 FORMAT parser *****************/
107
108/* FORMAT tokens returned by format_lex(). */
109typedef enum
110{
111 FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
74657812 112 FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
6de9cd9a 113 FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
de1ee8e1 114 FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
f2a71504
JD		 115 FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
116 FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
6de9cd9a
DN		 117}
118format_token;
119
120/* Local variables for checking format strings. The saved_token is
121 used to back up by a single format token during the parsing
122 process. */
00660189 123static gfc_char_t *format_string;
c8129db1 124static int format_string_pos;
6de9cd9a 125static int format_length, use_last_char;
9cad01ce
DK		 126static char error_element;
127static locus format_locus;
6de9cd9a
DN		 128
129static format_token saved_token;
130
131static enum
132{ MODE_STRING, MODE_FORMAT, MODE_COPY }
133mode;
134
135
136/* Return the next character in the format string. */
137
138static char
696abb30 139next_char (gfc_instring in_string)
6de9cd9a 140{
8fc541d3 141 static gfc_char_t c;
6de9cd9a
DN		 142
143 if (use_last_char)
144 {
145 use_last_char = 0;
146 return c;
147 }
148
149 format_length++;
150
151 if (mode == MODE_STRING)
152 c = *format_string++;
153 else
154 {
155 c = gfc_next_char_literal (in_string);
156 if (c == '\n')
157 c = '\0';
2e6a83a7
SK		 158 }
159
160 if (gfc_option.flag_backslash && c == '\\')
161 {
162 locus old_locus = gfc_current_locus;
6de9cd9a 163
8fc541d3 164 if (gfc_match_special_char (&c) == MATCH_NO)
a88a266c
SK		 165 gfc_current_locus = old_locus;
166
2e6a83a7
SK		 167 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
168 gfc_warning ("Extension: backslash character at %C");
6de9cd9a
DN		 169 }
170
2e6a83a7
SK		 171 if (mode == MODE_COPY)
172 *format_string++ = c;
173
9cad01ce
DK		 174 if (mode != MODE_STRING)
175 format_locus = gfc_current_locus;
176
c8129db1
JD		 177 format_string_pos++;
178
00660189 179 c = gfc_wide_toupper (c);
6de9cd9a
DN		 180 return c;
181}
182
183
184/* Back up one character position. Only works once. */
185
186static void
187unget_char (void)
188{
6de9cd9a
DN		 189 use_last_char = 1;
190}
191
66e4ab31 192/* Eat up the spaces and return a character. */
df3c4c81
JD		 193
194static char
c2df0359 195next_char_not_space (bool *error)
df3c4c81
JD		 196{
197 char c;
198 do
199 {
696abb30 200 error_element = c = next_char (NONSTRING);
c2df0359
TB		 201 if (c == '\t')
202 {
203 if (gfc_option.allow_std & GFC_STD_GNU)
204 gfc_warning ("Extension: Tab character in format at %C");
205 else
206 {
207 gfc_error ("Extension: Tab character in format at %C");
208 *error = true;
209 return c;
210 }
211 }
df3c4c81
JD		 212 }
213 while (gfc_is_whitespace (c));
214 return c;
215}
216
6de9cd9a
DN		 217static int value = 0;
218
219/* Simple lexical analyzer for getting the next token in a FORMAT
220 statement. */
221
222static format_token
223format_lex (void)
224{
225 format_token token;
226 char c, delim;
227 int zflag;
228 int negative_flag;
c2df0359 229 bool error = false;
6de9cd9a
DN		 230
231 if (saved_token != FMT_NONE)
232 {
233 token = saved_token;
234 saved_token = FMT_NONE;
235 return token;
236 }
237
c2df0359 238 c = next_char_not_space (&error);
df3c4c81 239
6de9cd9a
DN		 240 negative_flag = 0;
241 switch (c)
242 {
243 case '-':
244 negative_flag = 1;
efb63364
TB		 245 /* Falls through. */
246
6de9cd9a 247 case '+':
c2df0359 248 c = next_char_not_space (&error);
6de9cd9a
DN		 249 if (!ISDIGIT (c))
250 {
251 token = FMT_UNKNOWN;
252 break;
253 }
254
255 value = c - '0';
256
257 do
258 {
c2df0359 259 c = next_char_not_space (&error);
b251af97
SK		 260 if (ISDIGIT (c))
261 value = 10 * value + c - '0';
6de9cd9a
DN		 262 }
263 while (ISDIGIT (c));
264
265 unget_char ();
266
267 if (negative_flag)
b251af97 268 value = -value;
6de9cd9a
DN		 269
270 token = FMT_SIGNED_INT;
271 break;
272
273 case '0':
274 case '1':
275 case '2':
276 case '3':
277 case '4':
278 case '5':
279 case '6':
280 case '7':
281 case '8':
282 case '9':
283 zflag = (c == '0');
284
285 value = c - '0';
286
287 do
288 {
c2df0359 289 c = next_char_not_space (&error);
b251af97 290 if (ISDIGIT (c))
e444a887
TB		 291 {
292 value = 10 * value + c - '0';
293 if (c != '0')
294 zflag = 0;
295 }
6de9cd9a 296 }
df3c4c81 297 while (ISDIGIT (c));
6de9cd9a
DN		 298
299 unget_char ();
300 token = zflag ? FMT_ZERO : FMT_POSINT;
301 break;
302
303 case '.':
304 token = FMT_PERIOD;
305 break;
306
307 case ',':
308 token = FMT_COMMA;
309 break;
310
311 case ':':
312 token = FMT_COLON;
313 break;
314
315 case '/':
316 token = FMT_SLASH;
317 break;
318
319 case '$':
320 token = FMT_DOLLAR;
321 break;
322
323 case 'T':
c2df0359 324 c = next_char_not_space (&error);
74657812
JD		 325 switch (c)
326 {
327 case 'L':
328 token = FMT_TL;
329 break;
330 case 'R':
331 token = FMT_TR;
332 break;
333 default:
334 token = FMT_T;
335 unget_char ();
336 }
6de9cd9a
DN		 337 break;
338
339 case '(':
340 token = FMT_LPAREN;
341 break;
342
343 case ')':
344 token = FMT_RPAREN;
345 break;
346
347 case 'X':
348 token = FMT_X;
349 break;
350
351 case 'S':
c2df0359 352 c = next_char_not_space (&error);
6de9cd9a
DN		 353 if (c != 'P' && c != 'S')
354 unget_char ();
355
356 token = FMT_SIGN;
357 break;
358
359 case 'B':
c2df0359 360 c = next_char_not_space (&error);
6de9cd9a
DN		 361 if (c == 'N' || c == 'Z')
362 token = FMT_BLANK;
363 else
364 {
365 unget_char ();
366 token = FMT_IBOZ;
367 }
368
369 break;
370
371 case '\'':
372 case '"':
373 delim = c;
374
375 value = 0;
376
377 for (;;)
378 {
696abb30 379 c = next_char (INSTRING_WARN);
6de9cd9a
DN		 380 if (c == '\0')
381 {
382 token = FMT_END;
383 break;
384 }
385
386 if (c == delim)
387 {
696abb30 388 c = next_char (INSTRING_NOWARN);
6de9cd9a
DN		 389
390 if (c == '\0')
391 {
392 token = FMT_END;
393 break;
394 }
395
396 if (c != delim)
397 {
398 unget_char ();
399 token = FMT_CHAR;
400 break;
401 }
402 }
b251af97 403 value++;
6de9cd9a
DN		 404 }
405 break;
406
407 case 'P':
408 token = FMT_P;
409 break;
410
411 case 'I':
412 case 'O':
413 case 'Z':
414 token = FMT_IBOZ;
415 break;
416
417 case 'F':
418 token = FMT_F;
419 break;
420
421 case 'E':
c2df0359 422 c = next_char_not_space (&error);
de1ee8e1
JD		 423 if (c == 'N' )
424 token = FMT_EN;
425 else if (c == 'S')
426 token = FMT_ES;
6de9cd9a
DN		 427 else
428 {
429 token = FMT_E;
430 unget_char ();
431 }
432
433 break;
434
435 case 'G':
436 token = FMT_G;
437 break;
438
439 case 'H':
440 token = FMT_H;
441 break;
442
443 case 'L':
444 token = FMT_L;
445 break;
446
447 case 'A':
448 token = FMT_A;
449 break;
450
451 case 'D':
6f0f0b2e
JD		 452 c = next_char_not_space (&error);
453 if (c == 'P')
454 {
524af0d6
JB		 455 if (!gfc_notify_std (GFC_STD_F2003, "DP format "
456 "specifier not allowed at %C"))
9cad01ce 457 return FMT_ERROR;
6f0f0b2e
JD		 458 token = FMT_DP;
459 }
460 else if (c == 'C')
461 {
524af0d6
JB		 462 if (!gfc_notify_std (GFC_STD_F2003, "DC format "
463 "specifier not allowed at %C"))
9cad01ce 464 return FMT_ERROR;
6f0f0b2e
JD		 465 token = FMT_DC;
466 }
467 else
468 {
469 token = FMT_D;
470 unget_char ();
471 }
6de9cd9a
DN		 472 break;
473
f2a71504
JD		 474 case 'R':
475 c = next_char_not_space (&error);
476 switch (c)
477 {
478 case 'C':
479 token = FMT_RC;
480 break;
481 case 'D':
482 token = FMT_RD;
483 break;
484 case 'N':
485 token = FMT_RN;
486 break;
487 case 'P':
488 token = FMT_RP;
489 break;
490 case 'U':
491 token = FMT_RU;
492 break;
493 case 'Z':
494 token = FMT_RZ;
495 break;
496 default:
497 token = FMT_UNKNOWN;
498 unget_char ();
499 break;
500 }
501 break;
502
6de9cd9a
DN		 503 case '\0':
504 token = FMT_END;
505 break;
506
b823d9eb
JD		 507 case '*':
508 token = FMT_STAR;
509 break;
510
6de9cd9a
DN		 511 default:
512 token = FMT_UNKNOWN;
513 break;
514 }
515
c2df0359
TB		 516 if (error)
517 return FMT_ERROR;
518
6de9cd9a
DN		 519 return token;
520}
521
522
de1ee8e1
JD		 523static const char *
524token_to_string (format_token t)
525{
526 switch (t)
527 {
528 case FMT_D:
529 return "D";
530 case FMT_G:
531 return "G";
532 case FMT_E:
533 return "E";
534 case FMT_EN:
535 return "EN";
536 case FMT_ES:
537 return "ES";
538 default:
539 return "";
540 }
541}
542
6de9cd9a
DN		 543/* Check a format statement. The format string, either from a FORMAT
544 statement or a constant in an I/O statement has already been parsed
545 by itself, and we are checking it for validity. The dual origin
546 means that the warning message is a little less than great. */
547
524af0d6 548static bool
e444a887 549check_format (bool is_input)
6de9cd9a 550{
31043f6c 551 const char *posint_required = _("Positive width required");
31043f6c 552 const char *nonneg_required = _("Nonnegative width required");
9cad01ce
DK		 553 const char *unexpected_element = _("Unexpected element '%c' in format string"
554 " at %L");
31043f6c 555 const char *unexpected_end = _("Unexpected end of format string");
8955a005 556 const char *zero_width = _("Zero width in format descriptor");
6de9cd9a
DN		 557
558 const char *error;
559 format_token t, u;
560 int level;
561 int repeat;
524af0d6 562 bool rv;
6de9cd9a
DN		 563
564 use_last_char = 0;
565 saved_token = FMT_NONE;
566 level = 0;
567 repeat = 0;
524af0d6 568 rv = true;
c8129db1 569 format_string_pos = 0;
6de9cd9a
DN		 570
571 t = format_lex ();
c2df0359
TB		 572 if (t == FMT_ERROR)
573 goto fail;
6de9cd9a
DN		 574 if (t != FMT_LPAREN)
575 {
31043f6c 576 error = _("Missing leading left parenthesis");
6de9cd9a
DN		 577 goto syntax;
578 }
579
580 t = format_lex ();
c2df0359
TB		 581 if (t == FMT_ERROR)
582 goto fail;
6de9cd9a
DN		 583 if (t == FMT_RPAREN)
584 goto finished; /* Empty format is legal */
585 saved_token = t;
586
587format_item:
588 /* In this state, the next thing has to be a format item. */
589 t = format_lex ();
c2df0359
TB		 590 if (t == FMT_ERROR)
591 goto fail;
53d8a8ac 592format_item_1:
6de9cd9a
DN		 593 switch (t)
594 {
b823d9eb
JD		 595 case FMT_STAR:
596 repeat = -1;
597 t = format_lex ();
598 if (t == FMT_ERROR)
599 goto fail;
600 if (t == FMT_LPAREN)
601 {
602 level++;
603 goto format_item;
604 }
605 error = _("Left parenthesis required after '*'");
606 goto syntax;
607
6de9cd9a
DN		 608 case FMT_POSINT:
609 repeat = value;
610 t = format_lex ();
c2df0359
TB		 611 if (t == FMT_ERROR)
612 goto fail;
6de9cd9a
DN		 613 if (t == FMT_LPAREN)
614 {
615 level++;
616 goto format_item;
617 }
618
619 if (t == FMT_SLASH)
620 goto optional_comma;
621
622 goto data_desc;
623
624 case FMT_LPAREN:
625 level++;
626 goto format_item;
627
628 case FMT_SIGNED_INT:
df5be068 629 case FMT_ZERO:
6de9cd9a
DN		 630 /* Signed integer can only precede a P format. */
631 t = format_lex ();
c2df0359
TB		 632 if (t == FMT_ERROR)
633 goto fail;
6de9cd9a
DN		 634 if (t != FMT_P)
635 {
31043f6c 636 error = _("Expected P edit descriptor");
6de9cd9a
DN		 637 goto syntax;
638 }
639
640 goto data_desc;
641
642 case FMT_P:
8be123d4 643 /* P requires a prior number. */
31043f6c 644 error = _("P descriptor requires leading scale factor");
6de9cd9a
DN		 645 goto syntax;
646
647 case FMT_X:
8be123d4 648 /* X requires a prior number if we're being pedantic. */
3c6d5e12
JD		 649 if (mode != MODE_FORMAT)
650 format_locus.nextc += format_string_pos;
524af0d6
JB		 651 if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading "
652 "space count at %L", &format_locus))
653 return false;
e433aaee 654 goto between_desc;
6de9cd9a
DN		 655
656 case FMT_SIGN:
657 case FMT_BLANK:
6f0f0b2e
JD		 658 case FMT_DP:
659 case FMT_DC:
f2a71504
JD		 660 case FMT_RC:
661 case FMT_RD:
662 case FMT_RN:
663 case FMT_RP:
664 case FMT_RU:
665 case FMT_RZ:
6de9cd9a
DN		 666 goto between_desc;
667
11670eeb
RS		 668 case FMT_CHAR:
669 goto extension_optional_comma;
670
6de9cd9a
DN		 671 case FMT_COLON:
672 case FMT_SLASH:
673 goto optional_comma;
674
675 case FMT_DOLLAR:
676 t = format_lex ();
c2df0359
TB		 677 if (t == FMT_ERROR)
678 goto fail;
c9330b03 679
524af0d6
JB		 680 if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus))
681 return false;
6de9cd9a
DN		 682 if (t != FMT_RPAREN || level > 0)
683 {
b823d9eb
JD		 684 gfc_warning ("$ should be the last specifier in format at %L",
685 &format_locus);
7b666432 686 goto optional_comma_1;
6de9cd9a
DN		 687 }
688
689 goto finished;
690
74657812
JD		 691 case FMT_T:
692 case FMT_TL:
693 case FMT_TR:
6de9cd9a
DN		 694 case FMT_IBOZ:
695 case FMT_F:
696 case FMT_E:
de1ee8e1
JD		 697 case FMT_EN:
698 case FMT_ES:
6de9cd9a
DN		 699 case FMT_G:
700 case FMT_L:
701 case FMT_A:
702 case FMT_D:
6de9cd9a
DN		 703 case FMT_H:
704 goto data_desc;
705
706 case FMT_END:
707 error = unexpected_end;
708 goto syntax;
709
710 default:
711 error = unexpected_element;
712 goto syntax;
713 }
714
715data_desc:
716 /* In this state, t must currently be a data descriptor.
717 Deal with things that can/must follow the descriptor. */
718 switch (t)
719 {
720 case FMT_SIGN:
721 case FMT_BLANK:
6f0f0b2e
JD		 722 case FMT_DP:
723 case FMT_DC:
6de9cd9a
DN		 724 case FMT_X:
725 break;
726
727 case FMT_P:
3c6d5e12 728 /* No comma after P allowed only for F, E, EN, ES, D, or G.
e523d8bc
JD		 729 10.1.1 (1). */
730 t = format_lex ();
731 if (t == FMT_ERROR)
732 goto fail;
58fc89f6 733 if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA
e523d8bc 734 && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
c50d9687 735 && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
e523d8bc
JD		 736 {
737 error = _("Comma required after P descriptor");
738 goto syntax;
739 }
740 if (t != FMT_COMMA)
6de9cd9a 741 {
6de9cd9a
DN		 742 if (t == FMT_POSINT)
743 {
e523d8bc
JD		 744 t = format_lex ();
745 if (t == FMT_ERROR)
746 goto fail;
747 }
748 if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D
c50d9687 749 && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
e523d8bc
JD		 750 {
751 error = _("Comma required after P descriptor");
6de9cd9a
DN		 752 goto syntax;
753 }
6de9cd9a
DN		 754 }
755
e523d8bc 756 saved_token = t;
6de9cd9a
DN		 757 goto optional_comma;
758
74657812
JD		 759 case FMT_T:
760 case FMT_TL:
761 case FMT_TR:
762 t = format_lex ();
763 if (t != FMT_POSINT)
764 {
765 error = _("Positive width required with T descriptor");
766 goto syntax;
767 }
768 break;
769
6de9cd9a
DN		 770 case FMT_L:
771 t = format_lex ();
c2df0359
TB		 772 if (t == FMT_ERROR)
773 goto fail;
6de9cd9a
DN		 774 if (t == FMT_POSINT)
775 break;
776
8f0d39a8
FXC		 777 switch (gfc_notification_std (GFC_STD_GNU))
778 {
779 case WARNING:
b823d9eb
JD		 780 if (mode != MODE_FORMAT)
781 format_locus.nextc += format_string_pos;
b251af97 782 gfc_warning ("Extension: Missing positive width after L "
b823d9eb 783 "descriptor at %L", &format_locus);
8f0d39a8
FXC		 784 saved_token = t;
785 break;
786
787 case ERROR:
788 error = posint_required;
789 goto syntax;
790
791 case SILENT:
792 saved_token = t;
793 break;
794
795 default:
796 gcc_unreachable ();
797 }
798 break;
6de9cd9a
DN		 799
800 case FMT_A:
801 t = format_lex ();
c2df0359
TB		 802 if (t == FMT_ERROR)
803 goto fail;
8955a005
JD		 804 if (t == FMT_ZERO)
805 {
806 error = zero_width;
807 goto syntax;
808 }
6de9cd9a
DN		 809 if (t != FMT_POSINT)
810 saved_token = t;
811 break;
812
813 case FMT_D:
814 case FMT_E:
815 case FMT_G:
de1ee8e1
JD		 816 case FMT_EN:
817 case FMT_ES:
6de9cd9a 818 u = format_lex ();
8955a005
JD		 819 if (t == FMT_G && u == FMT_ZERO)
820 {
821 if (is_input)
822 {
823 error = zero_width;
824 goto syntax;
825 }
524af0d6
JB		 826 if (!gfc_notify_std (GFC_STD_F2008, "'G0' in format at %L",
827 &format_locus))
828 return false;
900e887f
JD		 829 u = format_lex ();
830 if (u != FMT_PERIOD)
831 {
832 saved_token = u;
833 break;
834 }
41d6f399 835 u = format_lex ();
900e887f 836 if (u != FMT_POSINT)
41d6f399 837 {
900e887f 838 error = posint_required;
41d6f399
JD		 839 goto syntax;
840 }
c8129db1
JD		 841 u = format_lex ();
842 if (u == FMT_E)
843 {
844 error = _("E specifier not allowed with g0 descriptor");
845 goto syntax;
846 }
847 saved_token = u;
900e887f 848 break;
6de9cd9a
DN		 849 }
850
de1ee8e1
JD		 851 if (u != FMT_POSINT)
852 {
853 format_locus.nextc += format_string_pos;
d0a2c5a9 854 gfc_error ("Positive width required in format "
de1ee8e1
JD		 855 "specifier %s at %L", token_to_string (t),
856 &format_locus);
857 saved_token = u;
d0a2c5a9 858 goto fail;
de1ee8e1
JD		 859 }
860
6de9cd9a 861 u = format_lex ();
c2df0359
TB		 862 if (u == FMT_ERROR)
863 goto fail;
6de9cd9a
DN		 864 if (u != FMT_PERIOD)
865 {
c9f4aa97 866 /* Warn if -std=legacy, otherwise error. */
de1ee8e1 867 format_locus.nextc += format_string_pos;
c9f4aa97 868 if (gfc_option.warn_std != 0)
de1ee8e1 869 {
d0a2c5a9 870 gfc_error ("Period required in format "
de1ee8e1
JD		 871 "specifier %s at %L", token_to_string (t),
872 &format_locus);
873 saved_token = u;
d0a2c5a9 874 goto fail;
de1ee8e1 875 }
c9f4aa97 876 else
de1ee8e1
JD		 877 gfc_warning ("Period required in format "
878 "specifier %s at %L", token_to_string (t),
879 &format_locus);
c50d9687
JD		 880 /* If we go to finished, we need to unwind this
881 before the next round. */
882 format_locus.nextc -= format_string_pos;
c9f4aa97
JD		 883 saved_token = u;
884 break;
6de9cd9a
DN		 885 }
886
887 u = format_lex ();
c2df0359
TB		 888 if (u == FMT_ERROR)
889 goto fail;
6de9cd9a
DN		 890 if (u != FMT_ZERO && u != FMT_POSINT)
891 {
892 error = nonneg_required;
893 goto syntax;
894 }
895
896 if (t == FMT_D)
897 break;
898
899 /* Look for optional exponent. */
900 u = format_lex ();
c2df0359
TB		 901 if (u == FMT_ERROR)
902 goto fail;
6de9cd9a
DN		 903 if (u != FMT_E)
904 {
905 saved_token = u;
906 }
907 else
908 {
909 u = format_lex ();
c2df0359
TB		 910 if (u == FMT_ERROR)
911 goto fail;
6de9cd9a
DN		 912 if (u != FMT_POSINT)
913 {
31043f6c 914 error = _("Positive exponent width required");
6de9cd9a
DN		 915 goto syntax;
916 }
917 }
918
919 break;
920
921 case FMT_F:
922 t = format_lex ();
c2df0359
TB		 923 if (t == FMT_ERROR)
924 goto fail;
6de9cd9a
DN		 925 if (t != FMT_ZERO && t != FMT_POSINT)
926 {
927 error = nonneg_required;
928 goto syntax;
929 }
e444a887
TB		 930 else if (is_input && t == FMT_ZERO)
931 {
932 error = posint_required;
933 goto syntax;
934 }
6de9cd9a
DN		 935
936 t = format_lex ();
c2df0359
TB		 937 if (t == FMT_ERROR)
938 goto fail;
6de9cd9a
DN		 939 if (t != FMT_PERIOD)
940 {
c9f4aa97 941 /* Warn if -std=legacy, otherwise error. */
b251af97 942 if (gfc_option.warn_std != 0)
b823d9eb 943 {
e523d8bc 944 error = _("Period required in format specifier");
b823d9eb
JD		 945 goto syntax;
946 }
e523d8bc
JD		 947 if (mode != MODE_FORMAT)
948 format_locus.nextc += format_string_pos;
b823d9eb
JD		 949 gfc_warning ("Period required in format specifier at %L",
950 &format_locus);
c9f4aa97
JD		 951 saved_token = t;
952 break;
6de9cd9a
DN		 953 }
954
955 t = format_lex ();
c2df0359
TB		 956 if (t == FMT_ERROR)
957 goto fail;
6de9cd9a
DN		 958 if (t != FMT_ZERO && t != FMT_POSINT)
959 {
960 error = nonneg_required;
961 goto syntax;
962 }
963
964 break;
965
966 case FMT_H:
a383cfa3 967 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
b823d9eb
JD		 968 {
969 if (mode != MODE_FORMAT)
970 format_locus.nextc += format_string_pos;
971 gfc_warning ("The H format specifier at %L is"
972 " a Fortran 95 deleted feature", &format_locus);
973 }
171fc18d
BD		 974 if (mode == MODE_STRING)
975 {
976 format_string += value;
977 format_length -= value;
d0a2c5a9 978 format_string_pos += repeat;
171fc18d
BD		 979 }
980 else
981 {
982 while (repeat >0)
983 {
696abb30 984 next_char (INSTRING_WARN);
171fc18d
BD		 985 repeat -- ;
986 }
987 }
6de9cd9a
DN		 988 break;
989
990 case FMT_IBOZ:
991 t = format_lex ();
c2df0359
TB		 992 if (t == FMT_ERROR)
993 goto fail;
6de9cd9a
DN		 994 if (t != FMT_ZERO && t != FMT_POSINT)
995 {
996 error = nonneg_required;
997 goto syntax;
998 }
e444a887
TB		 999 else if (is_input && t == FMT_ZERO)
1000 {
1001 error = posint_required;
1002 goto syntax;
1003 }
6de9cd9a
DN		 1004
1005 t = format_lex ();
c2df0359
TB		 1006 if (t == FMT_ERROR)
1007 goto fail;
6de9cd9a
DN		 1008 if (t != FMT_PERIOD)
1009 {
1010 saved_token = t;
1011 }
1012 else
1013 {
1014 t = format_lex ();
c2df0359
TB		 1015 if (t == FMT_ERROR)
1016 goto fail;
6de9cd9a
DN		 1017 if (t != FMT_ZERO && t != FMT_POSINT)
1018 {
1019 error = nonneg_required;
1020 goto syntax;
1021 }
1022 }
1023
1024 break;
1025
1026 default:
1027 error = unexpected_element;
1028 goto syntax;
1029 }
1030
1031between_desc:
1032 /* Between a descriptor and what comes next. */
1033 t = format_lex ();
c2df0359
TB		 1034 if (t == FMT_ERROR)
1035 goto fail;
6de9cd9a
DN		 1036 switch (t)
1037 {
1038
1039 case FMT_COMMA:
1040 goto format_item;
1041
1042 case FMT_RPAREN:
1043 level--;
1044 if (level < 0)
1045 goto finished;
1046 goto between_desc;
1047
1048 case FMT_COLON:
1049 case FMT_SLASH:
1050 goto optional_comma;
1051
1052 case FMT_END:
1053 error = unexpected_end;
1054 goto syntax;
1055
1056 default:
b823d9eb 1057 if (mode != MODE_FORMAT)
3c6d5e12 1058 format_locus.nextc += format_string_pos - 1;
524af0d6
JB		 1059 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
1060 return false;
c50d9687
JD		 1061 /* If we do not actually return a failure, we need to unwind this
1062 before the next round. */
1063 if (mode != MODE_FORMAT)
1064 format_locus.nextc -= format_string_pos;
53d8a8ac 1065 goto format_item_1;
6de9cd9a
DN		 1066 }
1067
1068optional_comma:
1069 /* Optional comma is a weird between state where we've just finished
7b666432 1070 reading a colon, slash, dollar or P descriptor. */
6de9cd9a 1071 t = format_lex ();
c2df0359
TB		 1072 if (t == FMT_ERROR)
1073 goto fail;
7b666432 1074optional_comma_1:
6de9cd9a
DN		 1075 switch (t)
1076 {
1077 case FMT_COMMA:
1078 break;
1079
1080 case FMT_RPAREN:
1081 level--;
1082 if (level < 0)
1083 goto finished;
1084 goto between_desc;
1085
1086 default:
1087 /* Assume that we have another format item. */
1088 saved_token = t;
1089 break;
1090 }
1091
1092 goto format_item;
1093
11670eeb
RS		 1094extension_optional_comma:
1095 /* As a GNU extension, permit a missing comma after a string literal. */
1096 t = format_lex ();
c2df0359
TB		 1097 if (t == FMT_ERROR)
1098 goto fail;
11670eeb
RS		 1099 switch (t)
1100 {
1101 case FMT_COMMA:
1102 break;
1103
1104 case FMT_RPAREN:
1105 level--;
1106 if (level < 0)
1107 goto finished;
1108 goto between_desc;
1109
1110 case FMT_COLON:
1111 case FMT_SLASH:
1112 goto optional_comma;
1113
1114 case FMT_END:
1115 error = unexpected_end;
1116 goto syntax;
1117
1118 default:
b823d9eb
JD		 1119 if (mode != MODE_FORMAT)
1120 format_locus.nextc += format_string_pos;
524af0d6
JB		 1121 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
1122 return false;
c50d9687
JD		 1123 /* If we do not actually return a failure, we need to unwind this
1124 before the next round. */
1125 if (mode != MODE_FORMAT)
1126 format_locus.nextc -= format_string_pos;
11670eeb
RS		 1127 saved_token = t;
1128 break;
1129 }
1130
1131 goto format_item;
b823d9eb 1132
6de9cd9a 1133syntax:
c8129db1
JD		 1134 if (mode != MODE_FORMAT)
1135 format_locus.nextc += format_string_pos;
9cad01ce
DK		 1136 if (error == unexpected_element)
1137 gfc_error (error, error_element, &format_locus);
1138 else
1139 gfc_error ("%s in format string at %L", error, &format_locus);
c2df0359 1140fail:
524af0d6 1141 rv = false;
6de9cd9a
DN		 1142
1143finished:
1144 return rv;
1145}
1146
1147
1148/* Given an expression node that is a constant string, see if it looks
1149 like a format string. */
1150
524af0d6 1151static bool
e444a887 1152check_format_string (gfc_expr *e, bool is_input)
6de9cd9a 1153{
524af0d6 1154 bool rv;
d0a2c5a9 1155 int i;
a48ebf39 1156 if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
524af0d6 1157 return true;
86e9d05f 1158
6de9cd9a
DN		 1159 mode = MODE_STRING;
1160 format_string = e->value.character.string;
171fc18d 1161
9cad01ce
DK		 1162 /* More elaborate measures are needed to show where a problem is within a
1163 format string that has been calculated, but that's probably not worth the
1164 effort. */
1165 format_locus = e->where;
d0a2c5a9
BD		 1166 rv = check_format (is_input);
1167 /* check for extraneous characters at the end of an otherwise valid format
1168 string, like '(A10,I3)F5'
1169 start at the end and move back to the last character processed,
1170 spaces are OK */
524af0d6 1171 if (rv && e->value.character.length > format_string_pos)
d0a2c5a9
BD		 1172 for (i=e->value.character.length-1;i>format_string_pos-1;i--)
1173 if (e->value.character.string[i] != ' ')
1174 {
1175 format_locus.nextc += format_length + 1;
1176 gfc_warning ("Extraneous characters in format at %L", &format_locus);
1177 break;
1178 }
1179 return rv;
6de9cd9a
DN		 1180}
1181
1182
1183/************ Fortran 95 I/O statement matchers *************/
1184
1185/* Match a FORMAT statement. This amounts to actually parsing the
1186 format descriptors in order to correctly locate the end of the
1187 format string. */
1188
1189match
1190gfc_match_format (void)
1191{
1192 gfc_expr *e;
1193 locus start;
1194
e0e85e06 1195 if (gfc_current_ns->proc_name
b251af97 1196 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
e0e85e06 1197 {
e25a0da3 1198 gfc_error ("Format statement in module main block at %C");
e0e85e06
PT		 1199 return MATCH_ERROR;
1200 }
1201
6de9cd9a
DN		 1202 if (gfc_statement_label == NULL)
1203 {
1204 gfc_error ("Missing format label at %C");
1205 return MATCH_ERROR;
1206 }
1207 gfc_gobble_whitespace ();
1208
1209 mode = MODE_FORMAT;
1210 format_length = 0;
1211
63645982 1212 start = gfc_current_locus;
6de9cd9a 1213
524af0d6 1214 if (!check_format (false))
6de9cd9a
DN		 1215 return MATCH_ERROR;
1216
1217 if (gfc_match_eos () != MATCH_YES)
1218 {
1219 gfc_syntax_error (ST_FORMAT);
1220 return MATCH_ERROR;
1221 }
1222
1223 /* The label doesn't get created until after the statement is done
1224 being matched, so we have to leave the string for later. */
1225
63645982 1226 gfc_current_locus = start; /* Back to the beginning */
6de9cd9a
DN		 1227
1228 new_st.loc = start;
1229 new_st.op = EXEC_NOP;
1230
b7e75771
JD		 1231 e = gfc_get_character_expr (gfc_default_character_kind, &start,
1232 NULL, format_length);
1233 format_string = e->value.character.string;
6de9cd9a
DN		 1234 gfc_statement_label->format = e;
1235
1236 mode = MODE_COPY;
e444a887 1237 check_format (false); /* Guaranteed to succeed */
6de9cd9a
DN		 1238 gfc_match_eos (); /* Guaranteed to succeed */
1239
1240 return MATCH_YES;
1241}
1242
1243
1244/* Match an expression I/O tag of some sort. */
1245
1246static match
b251af97 1247match_etag (const io_tag *tag, gfc_expr **v)
6de9cd9a
DN		 1248{
1249 gfc_expr *result;
1250 match m;
1251
9b8d1901 1252 m = gfc_match (tag->spec);
6de9cd9a
DN		 1253 if (m != MATCH_YES)
1254 return m;
1255
9b8d1901
TS		 1256 m = gfc_match (tag->value, &result);
1257 if (m != MATCH_YES)
1258 {
1259 gfc_error ("Invalid value for %s specification at %C", tag->name);
1260 return MATCH_ERROR;
1261 }
1262
6de9cd9a
DN		 1263 if (*v != NULL)
1264 {
1265 gfc_error ("Duplicate %s specification at %C", tag->name);
1266 gfc_free_expr (result);
1267 return MATCH_ERROR;
1268 }
1269
1270 *v = result;
1271 return MATCH_YES;
1272}
1273
1274
1275/* Match a variable I/O tag of some sort. */
1276
1277static match
b251af97 1278match_vtag (const io_tag *tag, gfc_expr **v)
6de9cd9a
DN		 1279{
1280 gfc_expr *result;
1281 match m;
1282
9b8d1901 1283 m = gfc_match (tag->spec);
6de9cd9a
DN		 1284 if (m != MATCH_YES)
1285 return m;
1286
9b8d1901
TS		 1287 m = gfc_match (tag->value, &result);
1288 if (m != MATCH_YES)
1289 {
1290 gfc_error ("Invalid value for %s specification at %C", tag->name);
1291 return MATCH_ERROR;
1292 }
1293
6de9cd9a
DN		 1294 if (*v != NULL)
1295 {
1296 gfc_error ("Duplicate %s specification at %C", tag->name);
1297 gfc_free_expr (result);
1298 return MATCH_ERROR;
1299 }
1300
1301 if (result->symtree->n.sym->attr.intent == INTENT_IN)
1302 {
3446fc50 1303 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
6de9cd9a
DN		 1304 gfc_free_expr (result);
1305 return MATCH_ERROR;
1306 }
1307
1308 if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1309 {
3446fc50
JD		 1310 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1311 tag->name);
6de9cd9a
DN		 1312 gfc_free_expr (result);
1313 return MATCH_ERROR;
1314 }
1315
f1f39033
PT		 1316 if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1317 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1318
6de9cd9a
DN		 1319 *v = result;
1320 return MATCH_YES;
1321}
1322
1323
c9583ed2
TS		 1324/* Match I/O tags that cause variables to become redefined. */
1325
1326static match
3446fc50 1327match_out_tag (const io_tag *tag, gfc_expr **result)
c9583ed2
TS		 1328{
1329 match m;
1330
3446fc50 1331 m = match_vtag (tag, result);
c9583ed2 1332 if (m == MATCH_YES)
3446fc50 1333 gfc_check_do_variable ((*result)->symtree);
c9583ed2
TS		 1334
1335 return m;
1336}
1337
1338
6de9cd9a
DN		 1339/* Match a label I/O tag. */
1340
1341static match
b251af97 1342match_ltag (const io_tag *tag, gfc_st_label ** label)
6de9cd9a
DN		 1343{
1344 match m;
1345 gfc_st_label *old;
1346
1347 old = *label;
9b8d1901
TS		 1348 m = gfc_match (tag->spec);
1349 if (m != MATCH_YES)
1350 return m;
1351
1352 m = gfc_match (tag->value, label);
1353 if (m != MATCH_YES)
1354 {
1355 gfc_error ("Invalid value for %s specification at %C", tag->name);
1356 return MATCH_ERROR;
1357 }
1358
1359 if (old)
6de9cd9a
DN		 1360 {
1361 gfc_error ("Duplicate %s label specification at %C", tag->name);
1362 return MATCH_ERROR;
1363 }
1364
524af0d6 1365 if (!gfc_reference_st_label (*label, ST_LABEL_TARGET))
89031799
TS		 1366 return MATCH_ERROR;
1367
6de9cd9a
DN		 1368 return m;
1369}
1370
1371
f25bf34f 1372/* Resolution of the FORMAT tag, to be called from resolve_tag. */
6de9cd9a 1373
524af0d6 1374static bool
f25bf34f 1375resolve_tag_format (const gfc_expr *e)
6de9cd9a 1376{
f25bf34f
TS		 1377 if (e->expr_type == EXPR_CONSTANT
1378 && (e->ts.type != BT_CHARACTER
1379 || e->ts.kind != gfc_default_character_kind))
6de9cd9a 1380 {
f25bf34f
TS		 1381 gfc_error ("Constant expression in FORMAT tag at %L must be "
1382 "of type default CHARACTER", &e->where);
524af0d6 1383 return false;
6de9cd9a
DN		 1384 }
1385
f25bf34f
TS		 1386 /* If e's rank is zero and e is not an element of an array, it should be
1387 of integer or character type. The integer variable should be
1388 ASSIGNED. */
7e279142
JJ		 1389 if (e->rank == 0
1390 && (e->expr_type != EXPR_VARIABLE
1391 || e->symtree == NULL
1392 || e->symtree->n.sym->as == NULL
1393 || e->symtree->n.sym->as->rank == 0))
6de9cd9a 1394 {
75933b07
TB		 1395 if ((e->ts.type != BT_CHARACTER
1396 || e->ts.kind != gfc_default_character_kind)
1397 && e->ts.type != BT_INTEGER)
7fd4d312 1398 {
75933b07
TB		 1399 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1400 "or of INTEGER", &e->where);
524af0d6 1401 return false;
7fd4d312 1402 }
f25bf34f 1403 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
6de9cd9a 1404 {
524af0d6
JB		 1405 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in "
1406 "FORMAT tag at %L", &e->where))
1407 return false;
f25bf34f 1408 if (e->symtree->n.sym->attr.assign != 1)
ba661c8b 1409 {
f25bf34f
TS		 1410 gfc_error ("Variable '%s' at %L has not been assigned a "
1411 "format label", e->symtree->n.sym->name, &e->where);
524af0d6 1412 return false;
ba661c8b 1413 }
6de9cd9a 1414 }
f25bf34f 1415 else if (e->ts.type == BT_INTEGER)
ce2df7c6 1416 {
f25bf34f
TS		 1417 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1418 "variable", gfc_basic_typename (e->ts.type), &e->where);
524af0d6 1419 return false;
ce2df7c6 1420 }
f25bf34f 1421
524af0d6 1422 return true;
f25bf34f
TS		 1423 }
1424
7e279142
JJ		 1425 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1426 It may be assigned an Hollerith constant. */
1427 if (e->ts.type != BT_CHARACTER)
6de9cd9a 1428 {
524af0d6
JB		 1429 if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
1430 "at %L", &e->where))
1431 return false;
7e279142
JJ		 1432
1433 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1434 {
1435 gfc_error ("Non-character assumed shape array element in FORMAT"
1436 " tag at %L", &e->where);
524af0d6 1437 return false;
7e279142
JJ		 1438 }
1439
1440 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1441 {
1442 gfc_error ("Non-character assumed size array element in FORMAT"
1443 " tag at %L", &e->where);
524af0d6 1444 return false;
7e279142
JJ		 1445 }
1446
1447 if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1448 {
1449 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1450 &e->where);
524af0d6 1451 return false;
7e279142 1452 }
f25bf34f 1453 }
418a78fa 1454
524af0d6 1455 return true;
f25bf34f 1456}
418a78fa 1457
e0e85e06 1458
f25bf34f 1459/* Do expression resolution and type-checking on an expression tag. */
418a78fa 1460
524af0d6 1461static bool
f25bf34f
TS		 1462resolve_tag (const io_tag *tag, gfc_expr *e)
1463{
1464 if (e == NULL)
524af0d6 1465 return true;
f25bf34f 1466
524af0d6
JB		 1467 if (!gfc_resolve_expr (e))
1468 return false;
f25bf34f
TS		 1469
1470 if (tag == &tag_format)
1471 return resolve_tag_format (e);
1472
1473 if (e->ts.type != tag->type)
1474 {
1475 gfc_error ("%s tag at %L must be of type %s", tag->name,
1476 &e->where, gfc_basic_typename (tag->type));
524af0d6 1477 return false;
6de9cd9a
DN		 1478 }
1479
75933b07
TB		 1480 if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
1481 {
1482 gfc_error ("%s tag at %L must be a character string of default kind",
1483 tag->name, &e->where);
524af0d6 1484 return false;
75933b07
TB		 1485 }
1486
f25bf34f
TS		 1487 if (e->rank != 0)
1488 {
1489 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
524af0d6 1490 return false;
f25bf34f
TS		 1491 }
1492
1493 if (tag == &tag_iomsg)
1494 {
524af0d6
JB		 1495 if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where))
1496 return false;
f25bf34f
TS		 1497 }
1498
1499 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1500 && e->ts.kind != gfc_default_integer_kind)
1501 {
524af0d6
JB		 1502 if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1503 "INTEGER in %s tag at %L", tag->name, &e->where))
1504 return false;
f25bf34f
TS		 1505 }
1506
92336ae1
SK		 1507 if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind)
1508 {
524af0d6
JB		 1509 if (!gfc_notify_std (GFC_STD_F2008, "Nondefault LOGICAL "
1510 "in %s tag at %L", tag->name, &e->where))
1511 return false;
92336ae1
SK		 1512 }
1513
8e8dc060
DK		 1514 if (tag == &tag_newunit)
1515 {
524af0d6
JB		 1516 if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L",
1517 &e->where))
1518 return false;
8e8dc060
DK		 1519 }
1520
1521 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1522 if (tag == &tag_newunit || tag == &tag_iostat
1523 || tag == &tag_size || tag == &tag_iomsg)
1524 {
1525 char context[64];
1526
1527 sprintf (context, _("%s tag"), tag->name);
524af0d6
JB		 1528 if (!gfc_check_vardef_context (e, false, false, false, context))
1529 return false;
8e8dc060
DK		 1530 }
1531
f25bf34f
TS		 1532 if (tag == &tag_convert)
1533 {
524af0d6
JB		 1534 if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where))
1535 return false;
f25bf34f 1536 }
8e8dc060 1537
524af0d6 1538 return true;
6de9cd9a
DN		 1539}
1540
1541
1542/* Match a single tag of an OPEN statement. */
1543
1544static match
b251af97 1545match_open_element (gfc_open *open)
6de9cd9a
DN		 1546{
1547 match m;
1548
d06b3496 1549 m = match_etag (&tag_e_async, &open->asynchronous);
6f0f0b2e
JD		 1550 if (m != MATCH_NO)
1551 return m;
6de9cd9a 1552 m = match_etag (&tag_unit, &open->unit);
7aba8abe
TK		 1553 if (m != MATCH_NO)
1554 return m;
1555 m = match_out_tag (&tag_iomsg, &open->iomsg);
6de9cd9a
DN		 1556 if (m != MATCH_NO)
1557 return m;
c9583ed2 1558 m = match_out_tag (&tag_iostat, &open->iostat);
6de9cd9a
DN		 1559 if (m != MATCH_NO)
1560 return m;
1561 m = match_etag (&tag_file, &open->file);
1562 if (m != MATCH_NO)
1563 return m;
1564 m = match_etag (&tag_status, &open->status);
1565 if (m != MATCH_NO)
1566 return m;
1567 m = match_etag (&tag_e_access, &open->access);
1568 if (m != MATCH_NO)
1569 return m;
1570 m = match_etag (&tag_e_form, &open->form);
1571 if (m != MATCH_NO)
1572 return m;
1573 m = match_etag (&tag_e_recl, &open->recl);
1574 if (m != MATCH_NO)
1575 return m;
1576 m = match_etag (&tag_e_blank, &open->blank);
1577 if (m != MATCH_NO)
1578 return m;
1579 m = match_etag (&tag_e_position, &open->position);
1580 if (m != MATCH_NO)
1581 return m;
1582 m = match_etag (&tag_e_action, &open->action);
1583 if (m != MATCH_NO)
1584 return m;
1585 m = match_etag (&tag_e_delim, &open->delim);
1586 if (m != MATCH_NO)
1587 return m;
1588 m = match_etag (&tag_e_pad, &open->pad);
6f0f0b2e
JD		 1589 if (m != MATCH_NO)
1590 return m;
1591 m = match_etag (&tag_e_decimal, &open->decimal);
1592 if (m != MATCH_NO)
1593 return m;
1594 m = match_etag (&tag_e_encoding, &open->encoding);
1595 if (m != MATCH_NO)
1596 return m;
1597 m = match_etag (&tag_e_round, &open->round);
1598 if (m != MATCH_NO)
1599 return m;
1600 m = match_etag (&tag_e_sign, &open->sign);
6de9cd9a
DN		 1601 if (m != MATCH_NO)
1602 return m;
1603 m = match_ltag (&tag_err, &open->err);
181c9f4a
TK		 1604 if (m != MATCH_NO)
1605 return m;
1606 m = match_etag (&tag_convert, &open->convert);
9ad55c33
JD		 1607 if (m != MATCH_NO)
1608 return m;
1609 m = match_out_tag (&tag_newunit, &open->newunit);
6de9cd9a
DN		 1610 if (m != MATCH_NO)
1611 return m;
1612
1613 return MATCH_NO;
1614}
1615
1616
1617/* Free the gfc_open structure and all the expressions it contains. */
1618
1619void
b251af97 1620gfc_free_open (gfc_open *open)
6de9cd9a 1621{
6de9cd9a
DN		 1622 if (open == NULL)
1623 return;
1624
1625 gfc_free_expr (open->unit);
7aba8abe 1626 gfc_free_expr (open->iomsg);
6de9cd9a
DN		 1627 gfc_free_expr (open->iostat);
1628 gfc_free_expr (open->file);
1629 gfc_free_expr (open->status);
1630 gfc_free_expr (open->access);
1631 gfc_free_expr (open->form);
1632 gfc_free_expr (open->recl);
1633 gfc_free_expr (open->blank);
1634 gfc_free_expr (open->position);
1635 gfc_free_expr (open->action);
1636 gfc_free_expr (open->delim);
1637 gfc_free_expr (open->pad);
6f0f0b2e
JD		 1638 gfc_free_expr (open->decimal);
1639 gfc_free_expr (open->encoding);
1640 gfc_free_expr (open->round);
1641 gfc_free_expr (open->sign);
181c9f4a 1642 gfc_free_expr (open->convert);
6f0f0b2e 1643 gfc_free_expr (open->asynchronous);
9ad55c33 1644 gfc_free_expr (open->newunit);
cede9502 1645 free (open);
6de9cd9a
DN		 1646}
1647
1648
1649/* Resolve everything in a gfc_open structure. */
1650
524af0d6 1651bool
b251af97 1652gfc_resolve_open (gfc_open *open)
6de9cd9a
DN		 1653{
1654
1655 RESOLVE_TAG (&tag_unit, open->unit);
7aba8abe 1656 RESOLVE_TAG (&tag_iomsg, open->iomsg);
6de9cd9a
DN		 1657 RESOLVE_TAG (&tag_iostat, open->iostat);
1658 RESOLVE_TAG (&tag_file, open->file);
1659 RESOLVE_TAG (&tag_status, open->status);
1e90e92f 1660 RESOLVE_TAG (&tag_e_access, open->access);
6de9cd9a
DN		 1661 RESOLVE_TAG (&tag_e_form, open->form);
1662 RESOLVE_TAG (&tag_e_recl, open->recl);
6de9cd9a
DN		 1663 RESOLVE_TAG (&tag_e_blank, open->blank);
1664 RESOLVE_TAG (&tag_e_position, open->position);
1665 RESOLVE_TAG (&tag_e_action, open->action);
1666 RESOLVE_TAG (&tag_e_delim, open->delim);
1667 RESOLVE_TAG (&tag_e_pad, open->pad);
6f0f0b2e
JD		 1668 RESOLVE_TAG (&tag_e_decimal, open->decimal);
1669 RESOLVE_TAG (&tag_e_encoding, open->encoding);
d06b3496 1670 RESOLVE_TAG (&tag_e_async, open->asynchronous);
6f0f0b2e
JD		 1671 RESOLVE_TAG (&tag_e_round, open->round);
1672 RESOLVE_TAG (&tag_e_sign, open->sign);
181c9f4a 1673 RESOLVE_TAG (&tag_convert, open->convert);
9ad55c33 1674 RESOLVE_TAG (&tag_newunit, open->newunit);
6de9cd9a 1675
524af0d6
JB		 1676 if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
1677 return false;
6de9cd9a 1678
524af0d6 1679 return true;
6de9cd9a
DN		 1680}
1681
1682
16dbbd99
FXC		 1683/* Check if a given value for a SPECIFIER is either in the list of values
1684 allowed in F95 or F2003, issuing an error message and returning a zero
1685 value if it is not allowed. */
b251af97 1686
16dbbd99 1687static int
b251af97
SK		 1688compare_to_allowed_values (const char *specifier, const char *allowed[],
1689 const char *allowed_f2003[],
00660189 1690 const char *allowed_gnu[], gfc_char_t *value,
b251af97 1691 const char *statement, bool warn)
16dbbd99
FXC		 1692{
1693 int i;
1694 unsigned int len;
1695
00660189 1696 len = gfc_wide_strlen (value);
16dbbd99
FXC		 1697 if (len > 0)
1698 {
1699 for (len--; len > 0; len--)
1700 if (value[len] != ' ')
1701 break;
1702 len++;
1703 }
1704
1705 for (i = 0; allowed[i]; i++)
b251af97 1706 if (len == strlen (allowed[i])
00660189 1707 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
16dbbd99
FXC		 1708 return 1;
1709
1710 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
b251af97 1711 if (len == strlen (allowed_f2003[i])
00660189
FXC		 1712 && gfc_wide_strncasecmp (value, allowed_f2003[i],
1713 strlen (allowed_f2003[i])) == 0)
16dbbd99
FXC		 1714 {
1715 notification n = gfc_notification_std (GFC_STD_F2003);
1716
1717 if (n == WARNING || (warn && n == ERROR))
1718 {
1719 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1720 "has value '%s'", specifier, statement,
1721 allowed_f2003[i]);
1722 return 1;
1723 }
1724 else
1725 if (n == ERROR)
1726 {
9717f7a1 1727 gfc_notify_std (GFC_STD_F2003, "%s specifier in "
16dbbd99
FXC		 1728 "%s statement at %C has value '%s'", specifier,
1729 statement, allowed_f2003[i]);
1730 return 0;
1731 }
1732
1733 /* n == SILENT */
1734 return 1;
1735 }
1736
1737 for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
b251af97 1738 if (len == strlen (allowed_gnu[i])
00660189
FXC		 1739 && gfc_wide_strncasecmp (value, allowed_gnu[i],
1740 strlen (allowed_gnu[i])) == 0)
16dbbd99
FXC		 1741 {
1742 notification n = gfc_notification_std (GFC_STD_GNU);
1743
1744 if (n == WARNING || (warn && n == ERROR))
1745 {
1746 gfc_warning ("Extension: %s specifier in %s statement at %C "
1747 "has value '%s'", specifier, statement,
1748 allowed_gnu[i]);
1749 return 1;
1750 }
1751 else
1752 if (n == ERROR)
1753 {
9717f7a1 1754 gfc_notify_std (GFC_STD_GNU, "%s specifier in "
16dbbd99
FXC		 1755 "%s statement at %C has value '%s'", specifier,
1756 statement, allowed_gnu[i]);
1757 return 0;
1758 }
1759
1760 /* n == SILENT */
1761 return 1;
1762 }
1763
1764 if (warn)
1765 {
00660189 1766 char *s = gfc_widechar_to_char (value, -1);
16dbbd99 1767 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
00660189 1768 specifier, statement, s);
cede9502 1769 free (s);
16dbbd99
FXC		 1770 return 1;
1771 }
1772 else
1773 {
00660189 1774 char *s = gfc_widechar_to_char (value, -1);
16dbbd99 1775 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
00660189 1776 specifier, statement, s);
cede9502 1777 free (s);
16dbbd99
FXC		 1778 return 0;
1779 }
1780}
1781
b251af97 1782
e7dc5b4f 1783/* Match an OPEN statement. */
6de9cd9a
DN		 1784
1785match
1786gfc_match_open (void)
1787{
1788 gfc_open *open;
1789 match m;
16dbbd99 1790 bool warn;
6de9cd9a
DN		 1791
1792 m = gfc_match_char ('(');
1793 if (m == MATCH_NO)
1794 return m;
1795
ece3f663 1796 open = XCNEW (gfc_open);
6de9cd9a
DN		 1797
1798 m = match_open_element (open);
1799
1800 if (m == MATCH_ERROR)
1801 goto cleanup;
1802 if (m == MATCH_NO)
1803 {
1804 m = gfc_match_expr (&open->unit);
6de9cd9a
DN		 1805 if (m == MATCH_ERROR)
1806 goto cleanup;
1807 }
1808
1809 for (;;)
1810 {
1811 if (gfc_match_char (')') == MATCH_YES)
1812 break;
1813 if (gfc_match_char (',') != MATCH_YES)
1814 goto syntax;
1815
1816 m = match_open_element (open);
1817 if (m == MATCH_ERROR)
1818 goto cleanup;
1819 if (m == MATCH_NO)
1820 goto syntax;
1821 }
1822
1823 if (gfc_match_eos () == MATCH_NO)
1824 goto syntax;
1825
1826 if (gfc_pure (NULL))
1827 {
1828 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1829 goto cleanup;
1830 }
1831
f1f39033
PT		 1832 if (gfc_implicit_pure (NULL))
1833 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1834
16dbbd99 1835 warn = (open->err || open->iostat) ? true : false;
9ad55c33
JD		 1836
1837 /* Checks on NEWUNIT specifier. */
1838 if (open->newunit)
1839 {
1840 if (open->unit)
1841 {
1842 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1843 goto cleanup;
1844 }
1845
1846 if (!(open->file || (open->status
1847 && gfc_wide_strncasecmp (open->status->value.character.string,
1848 "scratch", 7) == 0)))
1849 {
1850 gfc_error ("NEWUNIT specifier must have FILE= "
1851 "or STATUS='scratch' at %C");
1852 goto cleanup;
1853 }
1854 }
2b8f356c
JD		 1855 else if (!open->unit)
1856 {
1857 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1858 goto cleanup;
1859 }
9ad55c33 1860
16dbbd99
FXC		 1861 /* Checks on the ACCESS specifier. */
1862 if (open->access && open->access->expr_type == EXPR_CONSTANT)
1863 {
b251af97
SK		 1864 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1865 static const char *access_f2003[] = { "STREAM", NULL };
1866 static const char *access_gnu[] = { "APPEND", NULL };
16dbbd99
FXC		 1867
1868 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1869 access_gnu,
1870 open->access->value.character.string,
1871 "OPEN", warn))
1872 goto cleanup;
1873 }
1874
1875 /* Checks on the ACTION specifier. */
1876 if (open->action && open->action->expr_type == EXPR_CONSTANT)
1877 {
b251af97 1878 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
16dbbd99
FXC		 1879
1880 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1881 open->action->value.character.string,
1882 "OPEN", warn))
1883 goto cleanup;
1884 }
1885
1886 /* Checks on the ASYNCHRONOUS specifier. */
6f0f0b2e 1887 if (open->asynchronous)
16dbbd99 1888 {
524af0d6
JB		 1889 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C "
1890 "not allowed in Fortran 95"))
16dbbd99 1891 goto cleanup;
6f0f0b2e
JD		 1892
1893 if (open->asynchronous->expr_type == EXPR_CONSTANT)
1894 {
1895 static const char * asynchronous[] = { "YES", "NO", NULL };
1896
1897 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1898 NULL, NULL, open->asynchronous->value.character.string,
1899 "OPEN", warn))
1900 goto cleanup;
1901 }
1902 }
1903
16dbbd99 1904 /* Checks on the BLANK specifier. */
6f0f0b2e 1905 if (open->blank)
16dbbd99 1906 {
524af0d6
JB		 1907 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
1908 "not allowed in Fortran 95"))
16dbbd99 1909 goto cleanup;
6f0f0b2e
JD		 1910
1911 if (open->blank->expr_type == EXPR_CONSTANT)
1912 {
1913 static const char *blank[] = { "ZERO", "NULL", NULL };
1914
1915 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1916 open->blank->value.character.string,
1917 "OPEN", warn))
1918 goto cleanup;
1919 }
16dbbd99
FXC		 1920 }
1921
1922 /* Checks on the DECIMAL specifier. */
6f0f0b2e 1923 if (open->decimal)
16dbbd99 1924 {
524af0d6
JB		 1925 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
1926 "not allowed in Fortran 95"))
16dbbd99 1927 goto cleanup;
6f0f0b2e
JD		 1928
1929 if (open->decimal->expr_type == EXPR_CONSTANT)
1930 {
1931 static const char * decimal[] = { "COMMA", "POINT", NULL };
1932
1933 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1934 open->decimal->value.character.string,
1935 "OPEN", warn))
1936 goto cleanup;
1937 }
1938 }
16dbbd99
FXC		 1939
1940 /* Checks on the DELIM specifier. */
6f0f0b2e 1941 if (open->delim)
16dbbd99 1942 {
6f0f0b2e
JD		 1943 if (open->delim->expr_type == EXPR_CONSTANT)
1944 {
1945 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1946
1947 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1948 open->delim->value.character.string,
1949 "OPEN", warn))
1950 goto cleanup;
1951 }
16dbbd99
FXC		 1952 }
1953
1954 /* Checks on the ENCODING specifier. */
6f0f0b2e 1955 if (open->encoding)
16dbbd99 1956 {
524af0d6
JB		 1957 if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C "
1958 "not allowed in Fortran 95"))
d06b3496 1959 goto cleanup;
6f0f0b2e
JD		 1960
1961 if (open->encoding->expr_type == EXPR_CONSTANT)
1962 {
dad80a1b 1963 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
16dbbd99 1964
6f0f0b2e
JD		 1965 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1966 open->encoding->value.character.string,
1967 "OPEN", warn))
1968 goto cleanup;
1969 }
1970 }
16dbbd99
FXC		 1971
1972 /* Checks on the FORM specifier. */
1973 if (open->form && open->form->expr_type == EXPR_CONSTANT)
1974 {
b251af97 1975 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
16dbbd99
FXC		 1976
1977 if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1978 open->form->value.character.string,
1979 "OPEN", warn))
1980 goto cleanup;
1981 }
1982
1983 /* Checks on the PAD specifier. */
1984 if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1985 {
b251af97 1986 static const char *pad[] = { "YES", "NO", NULL };
16dbbd99
FXC		 1987
1988 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1989 open->pad->value.character.string,
1990 "OPEN", warn))
1991 goto cleanup;
1992 }
1993
1994 /* Checks on the POSITION specifier. */
1995 if (open->position && open->position->expr_type == EXPR_CONSTANT)
1996 {
b251af97 1997 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
16dbbd99
FXC		 1998
1999 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2000 open->position->value.character.string,
2001 "OPEN", warn))
2002 goto cleanup;
2003 }
2004
2005 /* Checks on the ROUND specifier. */
6f0f0b2e 2006 if (open->round)
16dbbd99 2007 {
524af0d6
JB		 2008 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
2009 "not allowed in Fortran 95"))
6f0f0b2e 2010 goto cleanup;
16dbbd99 2011
6f0f0b2e
JD		 2012 if (open->round->expr_type == EXPR_CONSTANT)
2013 {
2014 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2015 "COMPATIBLE", "PROCESSOR_DEFINED",
2016 NULL };
2017
2018 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2019 open->round->value.character.string,
2020 "OPEN", warn))
2021 goto cleanup;
2022 }
2023 }
16dbbd99
FXC		 2024
2025 /* Checks on the SIGN specifier. */
6f0f0b2e 2026 if (open->sign)
16dbbd99 2027 {
524af0d6
JB		 2028 if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
2029 "not allowed in Fortran 95"))
16dbbd99 2030 goto cleanup;
6f0f0b2e
JD		 2031
2032 if (open->sign->expr_type == EXPR_CONSTANT)
2033 {
2034 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2035 NULL };
2036
2037 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2038 open->sign->value.character.string,
2039 "OPEN", warn))
2040 goto cleanup;
2041 }
2042 }
16dbbd99
FXC		 2043
2044#define warn_or_error(...) \
2045{ \
2046 if (warn) \
2047 gfc_warning (__VA_ARGS__); \
2048 else \
2049 { \
2050 gfc_error (__VA_ARGS__); \
2051 goto cleanup; \
2052 } \
2053}
2054
2055 /* Checks on the RECL specifier. */
2056 if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2057 && open->recl->ts.type == BT_INTEGER
2058 && mpz_sgn (open->recl->value.integer) != 1)
2059 {
2060 warn_or_error ("RECL in OPEN statement at %C must be positive");
2061 }
2062
2063 /* Checks on the STATUS specifier. */
2064 if (open->status && open->status->expr_type == EXPR_CONSTANT)
2065 {
b251af97 2066 static const char *status[] = { "OLD", "NEW", "SCRATCH",
16dbbd99
FXC		 2067 "REPLACE", "UNKNOWN", NULL };
2068
2069 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2070 open->status->value.character.string,
2071 "OPEN", warn))
2072 goto cleanup;
2073
d06b3496
JD		 2074 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2075 the FILE= specifier shall appear. */
b251af97 2076 if (open->file == NULL
00660189
FXC		 2077 && (gfc_wide_strncasecmp (open->status->value.character.string,
2078 "replace", 7) == 0
2079 || gfc_wide_strncasecmp (open->status->value.character.string,
2080 "new", 3) == 0))
16dbbd99 2081 {
00660189
FXC		 2082 char *s = gfc_widechar_to_char (open->status->value.character.string,
2083 -1);
b251af97 2084 warn_or_error ("The STATUS specified in OPEN statement at %C is "
00660189 2085 "'%s' and no FILE specifier is present", s);
cede9502 2086 free (s);
16dbbd99
FXC		 2087 }
2088
d06b3496
JD		 2089 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2090 the FILE= specifier shall not appear. */
00660189
FXC		 2091 if (gfc_wide_strncasecmp (open->status->value.character.string,
2092 "scratch", 7) == 0 && open->file)
16dbbd99 2093 {
b251af97
SK		 2094 warn_or_error ("The STATUS specified in OPEN statement at %C "
2095 "cannot have the value SCRATCH if a FILE specifier "
16dbbd99
FXC		 2096 "is present");
2097 }
2098 }
2099
2100 /* Things that are not allowed for unformatted I/O. */
2101 if (open->form && open->form->expr_type == EXPR_CONSTANT
6f0f0b2e
JD		 2102 && (open->delim || open->decimal || open->encoding || open->round
2103 || open->sign || open->pad || open->blank)
00660189
FXC		 2104 && gfc_wide_strncasecmp (open->form->value.character.string,
2105 "unformatted", 11) == 0)
16dbbd99 2106 {
b251af97
SK		 2107 const char *spec = (open->delim ? "DELIM "
2108 : (open->pad ? "PAD " : open->blank
2109 ? "BLANK " : ""));
16dbbd99 2110
b251af97 2111 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
16dbbd99
FXC		 2112 "unformatted I/O", spec);
2113 }
2114
2115 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
00660189
FXC		 2116 && gfc_wide_strncasecmp (open->access->value.character.string,
2117 "stream", 6) == 0)
16dbbd99
FXC		 2118 {
2119 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2120 "stream I/O");
2121 }
2122
b251af97
SK		 2123 if (open->position
2124 && open->access && open->access->expr_type == EXPR_CONSTANT
00660189
FXC		 2125 && !(gfc_wide_strncasecmp (open->access->value.character.string,
2126 "sequential", 10) == 0
2127 || gfc_wide_strncasecmp (open->access->value.character.string,
2128 "stream", 6) == 0
2129 || gfc_wide_strncasecmp (open->access->value.character.string,
2130 "append", 6) == 0))
16dbbd99
FXC		 2131 {
2132 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2133 "for stream or sequential ACCESS");
2134 }
2135
2136#undef warn_or_error
2137
6de9cd9a
DN		 2138 new_st.op = EXEC_OPEN;
2139 new_st.ext.open = open;
2140 return MATCH_YES;
2141
2142syntax:
2143 gfc_syntax_error (ST_OPEN);
2144
2145cleanup:
2146 gfc_free_open (open);
2147 return MATCH_ERROR;
2148}
2149
2150
2151/* Free a gfc_close structure an all its expressions. */
2152
2153void
b251af97 2154gfc_free_close (gfc_close *close)
6de9cd9a 2155{
6de9cd9a
DN		 2156 if (close == NULL)
2157 return;
2158
2159 gfc_free_expr (close->unit);
7aba8abe 2160 gfc_free_expr (close->iomsg);
6de9cd9a
DN		 2161 gfc_free_expr (close->iostat);
2162 gfc_free_expr (close->status);
cede9502 2163 free (close);
6de9cd9a
DN		 2164}
2165
2166
e7dc5b4f 2167/* Match elements of a CLOSE statement. */
6de9cd9a
DN		 2168
2169static match
b251af97 2170match_close_element (gfc_close *close)
6de9cd9a
DN		 2171{
2172 match m;
2173
2174 m = match_etag (&tag_unit, &close->unit);
2175 if (m != MATCH_NO)
2176 return m;
2177 m = match_etag (&tag_status, &close->status);
7aba8abe
TK		 2178 if (m != MATCH_NO)
2179 return m;
2180 m = match_out_tag (&tag_iomsg, &close->iomsg);
6de9cd9a
DN		 2181 if (m != MATCH_NO)
2182 return m;
c9583ed2 2183 m = match_out_tag (&tag_iostat, &close->iostat);
6de9cd9a
DN		 2184 if (m != MATCH_NO)
2185 return m;
2186 m = match_ltag (&tag_err, &close->err);
2187 if (m != MATCH_NO)
2188 return m;
2189
2190 return MATCH_NO;
2191}
2192
2193
2194/* Match a CLOSE statement. */
2195
2196match
2197gfc_match_close (void)
2198{
2199 gfc_close *close;
2200 match m;
16dbbd99 2201 bool warn;
6de9cd9a
DN		 2202
2203 m = gfc_match_char ('(');
2204 if (m == MATCH_NO)
2205 return m;
2206
ece3f663 2207 close = XCNEW (gfc_close);
6de9cd9a
DN		 2208
2209 m = match_close_element (close);
2210
2211 if (m == MATCH_ERROR)
2212 goto cleanup;
2213 if (m == MATCH_NO)
2214 {
2215 m = gfc_match_expr (&close->unit);
2216 if (m == MATCH_NO)
2217 goto syntax;
2218 if (m == MATCH_ERROR)
2219 goto cleanup;
2220 }
2221
2222 for (;;)
2223 {
2224 if (gfc_match_char (')') == MATCH_YES)
2225 break;
2226 if (gfc_match_char (',') != MATCH_YES)
2227 goto syntax;
2228
2229 m = match_close_element (close);
2230 if (m == MATCH_ERROR)
2231 goto cleanup;
2232 if (m == MATCH_NO)
2233 goto syntax;
2234 }
2235
2236 if (gfc_match_eos () == MATCH_NO)
2237 goto syntax;
2238
2239 if (gfc_pure (NULL))
2240 {
2241 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2242 goto cleanup;
2243 }
2244
f1f39033
PT		 2245 if (gfc_implicit_pure (NULL))
2246 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2247
16dbbd99
FXC		 2248 warn = (close->iostat || close->err) ? true : false;
2249
2250 /* Checks on the STATUS specifier. */
2251 if (close->status && close->status->expr_type == EXPR_CONSTANT)
2252 {
b251af97 2253 static const char *status[] = { "KEEP", "DELETE", NULL };
16dbbd99
FXC		 2254
2255 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2256 close->status->value.character.string,
2257 "CLOSE", warn))
2258 goto cleanup;
2259 }
2260
6de9cd9a
DN		 2261 new_st.op = EXEC_CLOSE;
2262 new_st.ext.close = close;
2263 return MATCH_YES;
2264
2265syntax:
2266 gfc_syntax_error (ST_CLOSE);
2267
2268cleanup:
2269 gfc_free_close (close);
2270 return MATCH_ERROR;
2271}
2272
2273
2274/* Resolve everything in a gfc_close structure. */
2275
524af0d6 2276bool
b251af97 2277gfc_resolve_close (gfc_close *close)
6de9cd9a 2278{
6de9cd9a 2279 RESOLVE_TAG (&tag_unit, close->unit);
7aba8abe 2280 RESOLVE_TAG (&tag_iomsg, close->iomsg);
6de9cd9a
DN		 2281 RESOLVE_TAG (&tag_iostat, close->iostat);
2282 RESOLVE_TAG (&tag_status, close->status);
2283
524af0d6
JB		 2284 if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
2285 return false;
6de9cd9a 2286
b35f6a97
FXC		 2287 if (close->unit == NULL)
2288 {
2289 /* Find a locus from one of the arguments to close, when UNIT is
2290 not specified. */
2291 locus loc = gfc_current_locus;
2292 if (close->status)
2293 loc = close->status->where;
2294 else if (close->iostat)
2295 loc = close->iostat->where;
2296 else if (close->iomsg)
2297 loc = close->iomsg->where;
2298 else if (close->err)
2299 loc = close->err->where;
2300
2301 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc);
524af0d6 2302 return false;
b35f6a97
FXC		 2303 }
2304
9ad55c33
JD		 2305 if (close->unit->expr_type == EXPR_CONSTANT
2306 && close->unit->ts.type == BT_INTEGER
2307 && mpz_sgn (close->unit->value.integer) < 0)
2308 {
2309 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2310 &close->unit->where);
2311 }
2312
524af0d6 2313 return true;
6de9cd9a
DN		 2314}
2315
2316
2317/* Free a gfc_filepos structure. */
2318
2319void
b251af97 2320gfc_free_filepos (gfc_filepos *fp)
6de9cd9a 2321{
6de9cd9a 2322 gfc_free_expr (fp->unit);
7aba8abe 2323 gfc_free_expr (fp->iomsg);
6de9cd9a 2324 gfc_free_expr (fp->iostat);
cede9502 2325 free (fp);
6de9cd9a
DN		 2326}
2327
2328
6403ec5f 2329/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
6de9cd9a
DN		 2330
2331static match
b251af97 2332match_file_element (gfc_filepos *fp)
6de9cd9a
DN		 2333{
2334 match m;
2335
2336 m = match_etag (&tag_unit, &fp->unit);
7aba8abe
TK		 2337 if (m != MATCH_NO)
2338 return m;
2339 m = match_out_tag (&tag_iomsg, &fp->iomsg);
6de9cd9a
DN		 2340 if (m != MATCH_NO)
2341 return m;
c9583ed2 2342 m = match_out_tag (&tag_iostat, &fp->iostat);
6de9cd9a
DN		 2343 if (m != MATCH_NO)
2344 return m;
2345 m = match_ltag (&tag_err, &fp->err);
2346 if (m != MATCH_NO)
2347 return m;
2348
2349 return MATCH_NO;
2350}
2351
2352
2353/* Match the second half of the file-positioning statements, REWIND,
6403ec5f 2354 BACKSPACE, ENDFILE, or the FLUSH statement. */
6de9cd9a
DN		 2355
2356static match
2357match_filepos (gfc_statement st, gfc_exec_op op)
2358{
2359 gfc_filepos *fp;
2360 match m;
2361
ece3f663 2362 fp = XCNEW (gfc_filepos);
6de9cd9a
DN		 2363
2364 if (gfc_match_char ('(') == MATCH_NO)
2365 {
2366 m = gfc_match_expr (&fp->unit);
2367 if (m == MATCH_ERROR)
2368 goto cleanup;
2369 if (m == MATCH_NO)
2370 goto syntax;
2371
2372 goto done;
2373 }
2374
2375 m = match_file_element (fp);
2376 if (m == MATCH_ERROR)
2377 goto done;
2378 if (m == MATCH_NO)
2379 {
2380 m = gfc_match_expr (&fp->unit);
2381 if (m == MATCH_ERROR)
2382 goto done;
2383 if (m == MATCH_NO)
2384 goto syntax;
2385 }
2386
2387 for (;;)
2388 {
2389 if (gfc_match_char (')') == MATCH_YES)
2390 break;
2391 if (gfc_match_char (',') != MATCH_YES)
2392 goto syntax;
2393
2394 m = match_file_element (fp);
2395 if (m == MATCH_ERROR)
2396 goto cleanup;
2397 if (m == MATCH_NO)
2398 goto syntax;
2399 }
2400
2401done:
2402 if (gfc_match_eos () != MATCH_YES)
2403 goto syntax;
2404
2405 if (gfc_pure (NULL))
2406 {
2407 gfc_error ("%s statement not allowed in PURE procedure at %C",
2408 gfc_ascii_statement (st));
2409
2410 goto cleanup;
2411 }
2412
f1f39033
PT		 2413 if (gfc_implicit_pure (NULL))
2414 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2415
6de9cd9a
DN		 2416 new_st.op = op;
2417 new_st.ext.filepos = fp;
2418 return MATCH_YES;
2419
2420syntax:
2421 gfc_syntax_error (st);
2422
2423cleanup:
2424 gfc_free_filepos (fp);
2425 return MATCH_ERROR;
2426}
2427
2428
524af0d6 2429bool
b251af97 2430gfc_resolve_filepos (gfc_filepos *fp)
6de9cd9a 2431{
6de9cd9a 2432 RESOLVE_TAG (&tag_unit, fp->unit);
7aba8abe
TK		 2433 RESOLVE_TAG (&tag_iostat, fp->iostat);
2434 RESOLVE_TAG (&tag_iomsg, fp->iomsg);
524af0d6
JB		 2435 if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
2436 return false;
6de9cd9a 2437
9ad55c33
JD		 2438 if (fp->unit->expr_type == EXPR_CONSTANT
2439 && fp->unit->ts.type == BT_INTEGER
2440 && mpz_sgn (fp->unit->value.integer) < 0)
2441 {
2442 gfc_error ("UNIT number in statement at %L must be non-negative",
2443 &fp->unit->where);
2444 }
2445
524af0d6 2446 return true;
6de9cd9a
DN		 2447}
2448
2449
6403ec5f
JB		 2450/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2451 and the FLUSH statement. */
6de9cd9a
DN		 2452
2453match
2454gfc_match_endfile (void)
2455{
6de9cd9a
DN		 2456 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2457}
2458
2459match
2460gfc_match_backspace (void)
2461{
6de9cd9a
DN		 2462 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2463}
2464
2465match
2466gfc_match_rewind (void)
2467{
6de9cd9a
DN		 2468 return match_filepos (ST_REWIND, EXEC_REWIND);
2469}
2470
6403ec5f
JB		 2471match
2472gfc_match_flush (void)
2473{
524af0d6 2474 if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
6403ec5f
JB		 2475 return MATCH_ERROR;
2476
2477 return match_filepos (ST_FLUSH, EXEC_FLUSH);
2478}
6de9cd9a 2479
e7dc5b4f 2480/******************** Data Transfer Statements *********************/
6de9cd9a 2481
6de9cd9a
DN		 2482/* Return a default unit number. */
2483
2484static gfc_expr *
2485default_unit (io_kind k)
2486{
2487 int unit;
2488
2489 if (k == M_READ)
2490 unit = 5;
2491 else
2492 unit = 6;
2493
b7e75771 2494 return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
6de9cd9a
DN		 2495}
2496
2497
2498/* Match a unit specification for a data transfer statement. */
2499
2500static match
b251af97 2501match_dt_unit (io_kind k, gfc_dt *dt)
6de9cd9a
DN		 2502{
2503 gfc_expr *e;
2504
2505 if (gfc_match_char ('*') == MATCH_YES)
2506 {
2507 if (dt->io_unit != NULL)
2508 goto conflict;
2509
2510 dt->io_unit = default_unit (k);
2511 return MATCH_YES;
2512 }
2513
2514 if (gfc_match_expr (&e) == MATCH_YES)
2515 {
2516 if (dt->io_unit != NULL)
2517 {
2518 gfc_free_expr (e);
2519 goto conflict;
2520 }
2521
2522 dt->io_unit = e;
2523 return MATCH_YES;
2524 }
2525
2526 return MATCH_NO;
2527
2528conflict:
2529 gfc_error ("Duplicate UNIT specification at %C");
2530 return MATCH_ERROR;
2531}
2532
2533
2534/* Match a format specification. */
2535
2536static match
b251af97 2537match_dt_format (gfc_dt *dt)
6de9cd9a
DN		 2538{
2539 locus where;
2540 gfc_expr *e;
2541 gfc_st_label *label;
a48ebf39 2542 match m;
6de9cd9a 2543
63645982 2544 where = gfc_current_locus;
6de9cd9a
DN		 2545
2546 if (gfc_match_char ('*') == MATCH_YES)
2547 {
2548 if (dt->format_expr != NULL || dt->format_label != NULL)
2549 goto conflict;
2550
2551 dt->format_label = &format_asterisk;
2552 return MATCH_YES;
2553 }
2554
a48ebf39 2555 if ((m = gfc_match_st_label (&label)) == MATCH_YES)
6de9cd9a 2556 {
fc3c9491
SK		 2557 char c;
2558
2559 /* Need to check if the format label is actually either an operand
2560 to a user-defined operator or is a kind type parameter. That is,
2561 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2562 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2563
2564 gfc_gobble_whitespace ();
2565 c = gfc_peek_ascii_char ();
2566 if (c == '.' || c == '_')
2567 gfc_current_locus = where;
2568 else
6de9cd9a 2569 {
fc3c9491
SK		 2570 if (dt->format_expr != NULL || dt->format_label != NULL)
2571 {
2572 gfc_free_st_label (label);
2573 goto conflict;
2574 }
6de9cd9a 2575
524af0d6 2576 if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
fc3c9491 2577 return MATCH_ERROR;
6de9cd9a 2578
fc3c9491
SK		 2579 dt->format_label = label;
2580 return MATCH_YES;
2581 }
6de9cd9a 2582 }
a48ebf39
FXC		 2583 else if (m == MATCH_ERROR)
2584 /* The label was zero or too large. Emit the correct diagnosis. */
2585 return MATCH_ERROR;
6de9cd9a
DN		 2586
2587 if (gfc_match_expr (&e) == MATCH_YES)
2588 {
2589 if (dt->format_expr != NULL || dt->format_label != NULL)
2590 {
2591 gfc_free_expr (e);
2592 goto conflict;
2593 }
6de9cd9a
DN		 2594 dt->format_expr = e;
2595 return MATCH_YES;
2596 }
2597
63645982 2598 gfc_current_locus = where; /* The only case where we have to restore */
6de9cd9a
DN		 2599
2600 return MATCH_NO;
2601
2602conflict:
2603 gfc_error ("Duplicate format specification at %C");
2604 return MATCH_ERROR;
2605}
2606
2607
2608/* Traverse a namelist that is part of a READ statement to make sure
2609 that none of the variables in the namelist are INTENT(IN). Returns
2610 nonzero if we find such a variable. */
2611
2612static int
b251af97 2613check_namelist (gfc_symbol *sym)
6de9cd9a
DN		 2614{
2615 gfc_namelist *p;
2616
2617 for (p = sym->namelist; p; p = p->next)
2618 if (p->sym->attr.intent == INTENT_IN)
2619 {
2620 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2621 p->sym->name, sym->name);
2622 return 1;
2623 }
2624
2625 return 0;
2626}
2627
2628
2629/* Match a single data transfer element. */
2630
2631static match
b251af97 2632match_dt_element (io_kind k, gfc_dt *dt)
6de9cd9a
DN		 2633{
2634 char name[GFC_MAX_SYMBOL_LEN + 1];
2635 gfc_symbol *sym;
2636 match m;
2637
2638 if (gfc_match (" unit =") == MATCH_YES)
2639 {
2640 m = match_dt_unit (k, dt);
2641 if (m != MATCH_NO)
2642 return m;
2643 }
2644
2645 if (gfc_match (" fmt =") == MATCH_YES)
2646 {
2647 m = match_dt_format (dt);
2648 if (m != MATCH_NO)
2649 return m;
2650 }
2651
2652 if (gfc_match (" nml = %n", name) == MATCH_YES)
2653 {
2654 if (dt->namelist != NULL)
2655 {
2656 gfc_error ("Duplicate NML specification at %C");
2657 return MATCH_ERROR;
2658 }
2659
2660 if (gfc_find_symbol (name, NULL, 1, &sym))
2661 return MATCH_ERROR;
2662
2663 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2664 {
2665 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2666 sym != NULL ? sym->name : name);
2667 return MATCH_ERROR;
2668 }
2669
2670 dt->namelist = sym;
2671 if (k == M_READ && check_namelist (sym))
2672 return MATCH_ERROR;
2673
2674 return MATCH_YES;
2675 }
2676
d06b3496 2677 m = match_etag (&tag_e_async, &dt->asynchronous);
6f0f0b2e
JD		 2678 if (m != MATCH_NO)
2679 return m;
2680 m = match_etag (&tag_e_blank, &dt->blank);
2681 if (m != MATCH_NO)
2682 return m;
2683 m = match_etag (&tag_e_delim, &dt->delim);
2684 if (m != MATCH_NO)
2685 return m;
2686 m = match_etag (&tag_e_pad, &dt->pad);
2687 if (m != MATCH_NO)
2688 return m;
2689 m = match_etag (&tag_e_sign, &dt->sign);
2690 if (m != MATCH_NO)
2691 return m;
2692 m = match_etag (&tag_e_round, &dt->round);
2693 if (m != MATCH_NO)
2694 return m;
2695 m = match_out_tag (&tag_id, &dt->id);
2696 if (m != MATCH_NO)
2697 return m;
2698 m = match_etag (&tag_e_decimal, &dt->decimal);
2699 if (m != MATCH_NO)
2700 return m;
6de9cd9a 2701 m = match_etag (&tag_rec, &dt->rec);
014ec6ee
JD		 2702 if (m != MATCH_NO)
2703 return m;
4c934d41 2704 m = match_etag (&tag_spos, &dt->pos);
7aba8abe
TK		 2705 if (m != MATCH_NO)
2706 return m;
2707 m = match_out_tag (&tag_iomsg, &dt->iomsg);
6de9cd9a
DN		 2708 if (m != MATCH_NO)
2709 return m;
c9583ed2 2710 m = match_out_tag (&tag_iostat, &dt->iostat);
6de9cd9a
DN		 2711 if (m != MATCH_NO)
2712 return m;
2713 m = match_ltag (&tag_err, &dt->err);
e0e85e06
PT		 2714 if (m == MATCH_YES)
2715 dt->err_where = gfc_current_locus;
6de9cd9a
DN		 2716 if (m != MATCH_NO)
2717 return m;
2718 m = match_etag (&tag_advance, &dt->advance);
2719 if (m != MATCH_NO)
2720 return m;
c9583ed2 2721 m = match_out_tag (&tag_size, &dt->size);
6de9cd9a
DN		 2722 if (m != MATCH_NO)
2723 return m;
2724
2725 m = match_ltag (&tag_end, &dt->end);
2726 if (m == MATCH_YES)
365ff3b9
FXC		 2727 {
2728 if (k == M_WRITE)
2729 {
b251af97
SK		 2730 gfc_error ("END tag at %C not allowed in output statement");
2731 return MATCH_ERROR;
365ff3b9
FXC		 2732 }
2733 dt->end_where = gfc_current_locus;
2734 }
6de9cd9a
DN		 2735 if (m != MATCH_NO)
2736 return m;
2737
2738 m = match_ltag (&tag_eor, &dt->eor);
2739 if (m == MATCH_YES)
63645982 2740 dt->eor_where = gfc_current_locus;
6de9cd9a
DN		 2741 if (m != MATCH_NO)
2742 return m;
2743
2744 return MATCH_NO;
2745}
2746
2747
2748/* Free a data transfer structure and everything below it. */
2749
2750void
b251af97 2751gfc_free_dt (gfc_dt *dt)
6de9cd9a 2752{
6de9cd9a
DN		 2753 if (dt == NULL)
2754 return;
2755
2756 gfc_free_expr (dt->io_unit);
2757 gfc_free_expr (dt->format_expr);
2758 gfc_free_expr (dt->rec);
2759 gfc_free_expr (dt->advance);
7aba8abe 2760 gfc_free_expr (dt->iomsg);
6de9cd9a
DN		 2761 gfc_free_expr (dt->iostat);
2762 gfc_free_expr (dt->size);
6f0f0b2e
JD		 2763 gfc_free_expr (dt->pad);
2764 gfc_free_expr (dt->delim);
2765 gfc_free_expr (dt->sign);
2766 gfc_free_expr (dt->round);
2767 gfc_free_expr (dt->blank);
2768 gfc_free_expr (dt->decimal);
4c934d41 2769 gfc_free_expr (dt->pos);
8e8dc060
DK		 2770 gfc_free_expr (dt->dt_io_kind);
2771 /* dt->extra_comma is a link to dt_io_kind if it is set. */
cede9502 2772 free (dt);
6de9cd9a
DN		 2773}
2774
2775
2776/* Resolve everything in a gfc_dt structure. */
2777
524af0d6 2778bool
88e18fed 2779gfc_resolve_dt (gfc_dt *dt, locus *loc)
6de9cd9a
DN		 2780{
2781 gfc_expr *e;
8e8dc060
DK		 2782 io_kind k;
2783
2784 /* This is set in any case. */
2785 gcc_assert (dt->dt_io_kind);
2786 k = dt->dt_io_kind->value.iokind;
6de9cd9a
DN		 2787
2788 RESOLVE_TAG (&tag_format, dt->format_expr);
2789 RESOLVE_TAG (&tag_rec, dt->rec);
4c934d41 2790 RESOLVE_TAG (&tag_spos, dt->pos);
6de9cd9a 2791 RESOLVE_TAG (&tag_advance, dt->advance);
3446fc50 2792 RESOLVE_TAG (&tag_id, dt->id);
7aba8abe 2793 RESOLVE_TAG (&tag_iomsg, dt->iomsg);
6de9cd9a
DN		 2794 RESOLVE_TAG (&tag_iostat, dt->iostat);
2795 RESOLVE_TAG (&tag_size, dt->size);
6f0f0b2e
JD		 2796 RESOLVE_TAG (&tag_e_pad, dt->pad);
2797 RESOLVE_TAG (&tag_e_delim, dt->delim);
2798 RESOLVE_TAG (&tag_e_sign, dt->sign);
2799 RESOLVE_TAG (&tag_e_round, dt->round);
2800 RESOLVE_TAG (&tag_e_blank, dt->blank);
2801 RESOLVE_TAG (&tag_e_decimal, dt->decimal);
3446fc50 2802 RESOLVE_TAG (&tag_e_async, dt->asynchronous);
6de9cd9a
DN		 2803
2804 e = dt->io_unit;
88e18fed
JJ		 2805 if (e == NULL)
2806 {
2807 gfc_error ("UNIT not specified at %L", loc);
524af0d6 2808 return false;
88e18fed
JJ		 2809 }
2810
524af0d6 2811 if (gfc_resolve_expr (e)
6de9cd9a 2812 && (e->ts.type != BT_INTEGER
b251af97 2813 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
6de9cd9a 2814 {
ad7ee6f8
JD		 2815 /* If there is no extra comma signifying the "format" form of the IO
2816 statement, then this must be an error. */
2817 if (!dt->extra_comma)
2818 {
2819 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2820 "or a CHARACTER variable", &e->where);
524af0d6 2821 return false;
ad7ee6f8
JD		 2822 }
2823 else
2824 {
2825 /* At this point, we have an extra comma. If io_unit has arrived as
df2fba9e 2826 type character, we assume its really the "format" form of the I/O
ad7ee6f8 2827 statement. We set the io_unit to the default unit and format to
df2fba9e 2828 the character expression. See F95 Standard section 9.4. */
ad7ee6f8
JD		 2829 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2830 {
2831 dt->format_expr = dt->io_unit;
2832 dt->io_unit = default_unit (k);
2833
8e8dc060
DK		 2834 /* Nullify this pointer now so that a warning/error is not
2835 triggered below for the "Extension". */
ad7ee6f8
JD		 2836 dt->extra_comma = NULL;
2837 }
2838
2839 if (k == M_WRITE)
2840 {
2841 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2842 &dt->extra_comma->where);
524af0d6 2843 return false;
ad7ee6f8
JD		 2844 }
2845 }
6de9cd9a
DN		 2846 }
2847
6de9cd9a
DN		 2848 if (e->ts.type == BT_CHARACTER)
2849 {
4075a94e
PT		 2850 if (gfc_has_vector_index (e))
2851 {
b251af97 2852 gfc_error ("Internal unit with vector subscript at %L", &e->where);
524af0d6 2853 return false;
4075a94e 2854 }
8e8dc060
DK		 2855
2856 /* If we are writing, make sure the internal unit can be changed. */
2857 gcc_assert (k != M_PRINT);
2858 if (k == M_WRITE
524af0d6
JB		 2859 && !gfc_check_vardef_context (e, false, false, false,
2860 _("internal unit in WRITE")))
2861 return false;
e0e85e06 2862 }
4075a94e 2863
e0e85e06
PT		 2864 if (e->rank && e->ts.type != BT_CHARACTER)
2865 {
2866 gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
524af0d6 2867 return false;
6de9cd9a
DN		 2868 }
2869
9ad55c33
JD		 2870 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2871 && mpz_sgn (e->value.integer) < 0)
2872 {
8e8dc060
DK		 2873 gfc_error ("UNIT number in statement at %L must be non-negative",
2874 &e->where);
524af0d6 2875 return false;
9ad55c33
JD		 2876 }
2877
8e8dc060
DK		 2878 /* If we are reading and have a namelist, check that all namelist symbols
2879 can appear in a variable definition context. */
2880 if (k == M_READ && dt->namelist)
2881 {
2882 gfc_namelist* n;
2883 for (n = dt->namelist->namelist; n; n = n->next)
2884 {
2885 gfc_expr* e;
524af0d6 2886 bool t;
8e8dc060
DK		 2887
2888 e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
57bf28ea 2889 t = gfc_check_vardef_context (e, false, false, false, NULL);
8e8dc060
DK		 2890 gfc_free_expr (e);
2891
524af0d6 2892 if (!t)
8e8dc060
DK		 2893 {
2894 gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2895 " the symbol '%s' which may not appear in a"
2896 " variable definition context",
2897 dt->namelist->name, loc, n->sym->name);
524af0d6 2898 return false;
8e8dc060
DK		 2899 }
2900 }
2901 }
2902
ad7ee6f8 2903 if (dt->extra_comma
524af0d6
JB		 2904 && !gfc_notify_std (GFC_STD_GNU, "Comma before i/o item list at %L",
2905 &dt->extra_comma->where))
2906 return false;
ad7ee6f8 2907
e0e85e06 2908 if (dt->err)
6de9cd9a 2909 {
524af0d6
JB		 2910 if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
2911 return false;
e0e85e06 2912 if (dt->err->defined == ST_LABEL_UNKNOWN)
6de9cd9a 2913 {
e0e85e06
PT		 2914 gfc_error ("ERR tag label %d at %L not defined",
2915 dt->err->value, &dt->err_where);
524af0d6 2916 return false;
6de9cd9a 2917 }
e0e85e06 2918 }
6de9cd9a 2919
e0e85e06
PT		 2920 if (dt->end)
2921 {
524af0d6
JB		 2922 if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
2923 return false;
e0e85e06 2924 if (dt->end->defined == ST_LABEL_UNKNOWN)
6de9cd9a 2925 {
e0e85e06
PT		 2926 gfc_error ("END tag label %d at %L not defined",
2927 dt->end->value, &dt->end_where);
524af0d6 2928 return false;
6de9cd9a 2929 }
e0e85e06 2930 }
6de9cd9a 2931
e0e85e06
PT		 2932 if (dt->eor)
2933 {
524af0d6
JB		 2934 if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
2935 return false;
e0e85e06 2936 if (dt->eor->defined == ST_LABEL_UNKNOWN)
6de9cd9a 2937 {
e0e85e06
PT		 2938 gfc_error ("EOR tag label %d at %L not defined",
2939 dt->eor->value, &dt->eor_where);
524af0d6 2940 return false;
6de9cd9a
DN		 2941 }
2942 }
2943
1f2959f0 2944 /* Check the format label actually exists. */
6de9cd9a
DN		 2945 if (dt->format_label && dt->format_label != &format_asterisk
2946 && dt->format_label->defined == ST_LABEL_UNKNOWN)
2947 {
2948 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
b251af97 2949 &dt->format_label->where);
524af0d6 2950 return false;
6de9cd9a 2951 }
8e8dc060 2952
524af0d6 2953 return true;
6de9cd9a
DN		 2954}
2955
2956
2957/* Given an io_kind, return its name. */
2958
2959static const char *
2960io_kind_name (io_kind k)
2961{
2962 const char *name;
2963
2964 switch (k)
2965 {
2966 case M_READ:
2967 name = "READ";
2968 break;
2969 case M_WRITE:
2970 name = "WRITE";
2971 break;
2972 case M_PRINT:
2973 name = "PRINT";
2974 break;
2975 case M_INQUIRE:
2976 name = "INQUIRE";
2977 break;
2978 default:
2979 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2980 }
2981
2982 return name;
2983}
2984
2985
2986/* Match an IO iteration statement of the form:
2987
2988 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2989
2990 which is equivalent to a single IO element. This function is
2991 mutually recursive with match_io_element(). */
2992
b251af97 2993static match match_io_element (io_kind, gfc_code **);
6de9cd9a
DN		 2994
2995static match
b251af97 2996match_io_iterator (io_kind k, gfc_code **result)
6de9cd9a 2997{
7b901ac4 2998 gfc_code *head, *tail, *new_code;
6de9cd9a
DN		 2999 gfc_iterator *iter;
3000 locus old_loc;
3001 match m;
3002 int n;
3003
3004 iter = NULL;
3005 head = NULL;
63645982 3006 old_loc = gfc_current_locus;
6de9cd9a
DN		 3007
3008 if (gfc_match_char ('(') != MATCH_YES)
3009 return MATCH_NO;
3010
3011 m = match_io_element (k, &head);
3012 tail = head;
3013
3014 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3015 {
3016 m = MATCH_NO;
3017 goto cleanup;
3018 }
3019
3020 /* Can't be anything but an IO iterator. Build a list. */
3021 iter = gfc_get_iterator ();
3022
3023 for (n = 1;; n++)
3024 {
3025 m = gfc_match_iterator (iter, 0);
3026 if (m == MATCH_ERROR)
3027 goto cleanup;
3028 if (m == MATCH_YES)
c9583ed2
TS		 3029 {
3030 gfc_check_do_variable (iter->var->symtree);
3031 break;
3032 }
6de9cd9a 3033
7b901ac4 3034 m = match_io_element (k, &new_code);
6de9cd9a
DN		 3035 if (m == MATCH_ERROR)
3036 goto cleanup;
3037 if (m == MATCH_NO)
3038 {
3039 if (n > 2)
3040 goto syntax;
3041 goto cleanup;
3042 }
3043
7b901ac4 3044 tail = gfc_append_code (tail, new_code);
6de9cd9a
DN		 3045
3046 if (gfc_match_char (',') != MATCH_YES)
3047 {
3048 if (n > 2)
3049 goto syntax;
3050 m = MATCH_NO;
3051 goto cleanup;
3052 }
3053 }
3054
3055 if (gfc_match_char (')') != MATCH_YES)
3056 goto syntax;
3057
11e5274a 3058 new_code = gfc_get_code (EXEC_DO);
7b901ac4 3059 new_code->ext.iterator = iter;
6de9cd9a 3060
11e5274a 3061 new_code->block = gfc_get_code (EXEC_DO);
7b901ac4 3062 new_code->block->next = head;
6de9cd9a 3063
7b901ac4 3064 *result = new_code;
6de9cd9a
DN		 3065 return MATCH_YES;
3066
3067syntax:
3068 gfc_error ("Syntax error in I/O iterator at %C");
3069 m = MATCH_ERROR;
3070
3071cleanup:
3072 gfc_free_iterator (iter, 1);
3073 gfc_free_statements (head);
63645982 3074 gfc_current_locus = old_loc;
6de9cd9a
DN		 3075 return m;
3076}
3077
3078
3079/* Match a single element of an IO list, which is either a single
3080 expression or an IO Iterator. */
3081
3082static match
b251af97 3083match_io_element (io_kind k, gfc_code **cpp)
6de9cd9a
DN		 3084{
3085 gfc_expr *expr;
3086 gfc_code *cp;
3087 match m;
3088
3089 expr = NULL;
3090
3091 m = match_io_iterator (k, cpp);
3092 if (m == MATCH_YES)
3093 return MATCH_YES;
3094
3095 if (k == M_READ)
3096 {
3097 m = gfc_match_variable (&expr, 0);
3098 if (m == MATCH_NO)
3099 gfc_error ("Expected variable in READ statement at %C");
3100 }
3101 else
3102 {
3103 m = gfc_match_expr (&expr);
3104 if (m == MATCH_NO)
3105 gfc_error ("Expected expression in %s statement at %C",
3106 io_kind_name (k));
3107 }
3108
8e8dc060
DK		 3109 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3110 m = MATCH_ERROR;
6de9cd9a
DN		 3111
3112 if (m != MATCH_YES)
3113 {
3114 gfc_free_expr (expr);
3115 return MATCH_ERROR;
3116 }
3117
11e5274a 3118 cp = gfc_get_code (EXEC_TRANSFER);
a513927a 3119 cp->expr1 = expr;
70b9ed88
JD		 3120 if (k != M_INQUIRE)
3121 cp->ext.dt = current_dt;
6de9cd9a
DN		 3122
3123 *cpp = cp;
3124 return MATCH_YES;
3125}
3126
3127
3128/* Match an I/O list, building gfc_code structures as we go. */
3129
3130static match
b251af97 3131match_io_list (io_kind k, gfc_code **head_p)
6de9cd9a 3132{
7b901ac4 3133 gfc_code *head, *tail, *new_code;
6de9cd9a
DN		 3134 match m;
3135
3136 *head_p = head = tail = NULL;
3137 if (gfc_match_eos () == MATCH_YES)
3138 return MATCH_YES;
3139
3140 for (;;)
3141 {
7b901ac4 3142 m = match_io_element (k, &new_code);
6de9cd9a
DN		 3143 if (m == MATCH_ERROR)
3144 goto cleanup;
3145 if (m == MATCH_NO)
3146 goto syntax;
3147
7b901ac4 3148 tail = gfc_append_code (tail, new_code);
6de9cd9a 3149 if (head == NULL)
7b901ac4 3150 head = new_code;
6de9cd9a
DN		 3151
3152 if (gfc_match_eos () == MATCH_YES)
3153 break;
3154 if (gfc_match_char (',') != MATCH_YES)
3155 goto syntax;
3156 }
3157
3158 *head_p = head;
3159 return MATCH_YES;
3160
3161syntax:
3162 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3163
3164cleanup:
3165 gfc_free_statements (head);
3166 return MATCH_ERROR;
3167}
3168
3169
3170/* Attach the data transfer end node. */
3171
3172static void
b251af97 3173terminate_io (gfc_code *io_code)
6de9cd9a
DN		 3174{
3175 gfc_code *c;
3176
3177 if (io_code == NULL)
5e805e44 3178 io_code = new_st.block;
6de9cd9a 3179
11e5274a 3180 c = gfc_get_code (EXEC_DT_END);
6de9cd9a
DN		 3181
3182 /* Point to structure that is already there */
3183 c->ext.dt = new_st.ext.dt;
3184 gfc_append_code (io_code, c);
3185}
3186
3187
e0e85e06
PT		 3188/* Check the constraints for a data transfer statement. The majority of the
3189 constraints appearing in 9.4 of the standard appear here. Some are handled
3190 in resolve_tag and others in gfc_resolve_dt. */
3191
3192static match
b251af97
SK		 3193check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3194 locus *spec_end)
e0e85e06
PT		 3195{
3196#define io_constraint(condition,msg,arg)\
3197if (condition) \
3198 {\
3199 gfc_error(msg,arg);\
3200 m = MATCH_ERROR;\
3201 }
3202
3203 match m;
b251af97
SK		 3204 gfc_expr *expr;
3205 gfc_symbol *sym = NULL;
6f0f0b2e
JD		 3206 bool warn, unformatted;
3207
3208 warn = (dt->err || dt->iostat) ? true : false;
3209 unformatted = dt->format_expr == NULL && dt->format_label == NULL
3210 && dt->namelist == NULL;
e0e85e06
PT		 3211
3212 m = MATCH_YES;
3213
3214 expr = dt->io_unit;
3215 if (expr && expr->expr_type == EXPR_VARIABLE
b251af97 3216 && expr->ts.type == BT_CHARACTER)
e0e85e06
PT		 3217 {
3218 sym = expr->symtree->n.sym;
3219
3220 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3221 "Internal file at %L must not be INTENT(IN)",
3222 &expr->where);
3223
3224 io_constraint (gfc_has_vector_index (dt->io_unit),
3225 "Internal file incompatible with vector subscript at %L",
3226 &expr->where);
3227
3228 io_constraint (dt->rec != NULL,
3229 "REC tag at %L is incompatible with internal file",
3230 &dt->rec->where);
f5c64803
JD		 3231
3232 io_constraint (dt->pos != NULL,
3233 "POS tag at %L is incompatible with internal file",
3234 &dt->pos->where);
e0e85e06 3235
6f0f0b2e 3236 io_constraint (unformatted,
89c32b0f
TB		 3237 "Unformatted I/O not allowed with internal unit at %L",
3238 &dt->io_unit->where);
3239
6f0f0b2e
JD		 3240 io_constraint (dt->asynchronous != NULL,
3241 "ASYNCHRONOUS tag at %L not allowed with internal file",
3242 &dt->asynchronous->where);
3243
f1827a8c 3244 if (dt->namelist != NULL)
b251af97 3245 {
524af0d6
JB		 3246 if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3247 "namelist", &expr->where))
b251af97
SK		 3248 m = MATCH_ERROR;
3249 }
e0e85e06
PT		 3250
3251 io_constraint (dt->advance != NULL,
3252 "ADVANCE tag at %L is incompatible with internal file",
3253 &dt->advance->where);
3254 }
3255
3256 if (expr && expr->ts.type != BT_CHARACTER)
3257 {
3258
b251af97 3259 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
e0e85e06
PT		 3260 "IO UNIT in %s statement at %C must be "
3261 "an internal file in a PURE procedure",
3262 io_kind_name (k));
f1f39033
PT		 3263
3264 if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
3265 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3266
e0e85e06
PT		 3267 }
3268
e0e85e06
PT		 3269 if (k != M_READ)
3270 {
b251af97 3271 io_constraint (dt->end, "END tag not allowed with output at %L",
e0e85e06
PT		 3272 &dt->end_where);
3273
b251af97 3274 io_constraint (dt->eor, "EOR tag not allowed with output at %L",
e0e85e06
PT		 3275 &dt->eor_where);
3276
d06b3496 3277 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
6f0f0b2e
JD		 3278 &dt->blank->where);
3279
d06b3496 3280 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
6f0f0b2e
JD		 3281 &dt->pad->where);
3282
d06b3496 3283 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
e0e85e06
PT		 3284 &dt->size->where);
3285 }
3286 else
3287 {
3288 io_constraint (dt->size && dt->advance == NULL,
3289 "SIZE tag at %L requires an ADVANCE tag",
3290 &dt->size->where);
3291
3292 io_constraint (dt->eor && dt->advance == NULL,
3293 "EOR tag at %L requires an ADVANCE tag",
3294 &dt->eor_where);
3295 }
3296
fbe88ffa 3297 if (dt->asynchronous)
6f0f0b2e
JD		 3298 {
3299 static const char * asynchronous[] = { "YES", "NO", NULL };
3300
524af0d6 3301 if (!gfc_reduce_init_expr (dt->asynchronous))
fbe88ffa
TB		 3302 {
3303 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3304 "expression", &dt->asynchronous->where);
3305 return MATCH_ERROR;
3306 }
3307
6f0f0b2e
JD		 3308 if (!compare_to_allowed_values
3309 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3310 dt->asynchronous->value.character.string,
3311 io_kind_name (k), warn))
3312 return MATCH_ERROR;
3313 }
3314
3315 if (dt->id)
3316 {
00660189
FXC		 3317 bool not_yes
3318 = !dt->asynchronous
3319 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3320 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3321 "yes", 3) != 0;
3322 io_constraint (not_yes,
d06b3496 3323 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
6f0f0b2e
JD		 3324 "specifier", &dt->id->where);
3325 }
3326
3327 if (dt->decimal)
3328 {
524af0d6
JB		 3329 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
3330 "not allowed in Fortran 95"))
6f0f0b2e
JD		 3331 return MATCH_ERROR;
3332
3333 if (dt->decimal->expr_type == EXPR_CONSTANT)
3334 {
3335 static const char * decimal[] = { "COMMA", "POINT", NULL };
3336
3337 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3338 dt->decimal->value.character.string,
3339 io_kind_name (k), warn))
3340 return MATCH_ERROR;
3341
3342 io_constraint (unformatted,
d06b3496 3343 "the DECIMAL= specifier at %L must be with an "
6f0f0b2e
JD		 3344 "explicit format expression", &dt->decimal->where);
3345 }
3346 }
3347
3348 if (dt->blank)
3349 {
524af0d6
JB		 3350 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
3351 "not allowed in Fortran 95"))
6f0f0b2e
JD		 3352 return MATCH_ERROR;
3353
3354 if (dt->blank->expr_type == EXPR_CONSTANT)
3355 {
3356 static const char * blank[] = { "NULL", "ZERO", NULL };
3357
3358 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3359 dt->blank->value.character.string,
3360 io_kind_name (k), warn))
3361 return MATCH_ERROR;
3362
3363 io_constraint (unformatted,
d06b3496 3364 "the BLANK= specifier at %L must be with an "
6f0f0b2e
JD		 3365 "explicit format expression", &dt->blank->where);
3366 }
3367 }
3368
3369 if (dt->pad)
3370 {
524af0d6
JB		 3371 if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
3372 "not allowed in Fortran 95"))
6f0f0b2e
JD		 3373 return MATCH_ERROR;
3374
3375 if (dt->pad->expr_type == EXPR_CONSTANT)
3376 {
3377 static const char * pad[] = { "YES", "NO", NULL };
3378
3379 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3380 dt->pad->value.character.string,
3381 io_kind_name (k), warn))
3382 return MATCH_ERROR;
3383
3384 io_constraint (unformatted,
d06b3496 3385 "the PAD= specifier at %L must be with an "
6f0f0b2e
JD		 3386 "explicit format expression", &dt->pad->where);
3387 }
3388 }
3389
3390 if (dt->round)
3391 {
524af0d6
JB		 3392 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
3393 "not allowed in Fortran 95"))
f2a71504 3394 return MATCH_ERROR;
6f0f0b2e
JD		 3395
3396 if (dt->round->expr_type == EXPR_CONSTANT)
3397 {
3398 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3399 "COMPATIBLE", "PROCESSOR_DEFINED",
3400 NULL };
3401
3402 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3403 dt->round->value.character.string,
3404 io_kind_name (k), warn))
3405 return MATCH_ERROR;
3406 }
3407 }
3408
3409 if (dt->sign)
3410 {
3411 /* When implemented, change the following to use gfc_notify_std F2003.
9717f7a1 3412 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
524af0d6 3413 "not allowed in Fortran 95") == false)
6f0f0b2e
JD		 3414 return MATCH_ERROR; */
3415 if (dt->sign->expr_type == EXPR_CONSTANT)
3416 {
3417 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3418 NULL };
3419
3420 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3421 dt->sign->value.character.string,
3422 io_kind_name (k), warn))
3423 return MATCH_ERROR;
3424
3425 io_constraint (unformatted,
d06b3496 3426 "SIGN= specifier at %L must be with an "
6f0f0b2e 3427 "explicit format expression", &dt->sign->where);
e0e85e06 3428
6f0f0b2e 3429 io_constraint (k == M_READ,
d06b3496 3430 "SIGN= specifier at %L not allowed in a "
6f0f0b2e
JD		 3431 "READ statement", &dt->sign->where);
3432 }
3433 }
3434
3435 if (dt->delim)
3436 {
524af0d6
JB		 3437 if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
3438 "not allowed in Fortran 95"))
6f0f0b2e 3439 return MATCH_ERROR;
e0e85e06 3440
6f0f0b2e
JD		 3441 if (dt->delim->expr_type == EXPR_CONSTANT)
3442 {
3443 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3444
3445 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3446 dt->delim->value.character.string,
3447 io_kind_name (k), warn))
3448 return MATCH_ERROR;
3449
3450 io_constraint (k == M_READ,
d06b3496 3451 "DELIM= specifier at %L not allowed in a "
6f0f0b2e
JD		 3452 "READ statement", &dt->delim->where);
3453
3454 io_constraint (dt->format_label != &format_asterisk
3455 && dt->namelist == NULL,
d06b3496 3456 "DELIM= specifier at %L must have FMT=*",
6f0f0b2e
JD		 3457 &dt->delim->where);
3458
3459 io_constraint (unformatted && dt->namelist == NULL,
d06b3496
JD		 3460 "DELIM= specifier at %L must be with FMT=* or "
3461 "NML= specifier ", &dt->delim->where);
6f0f0b2e
JD		 3462 }
3463 }
3464
e0e85e06
PT		 3465 if (dt->namelist)
3466 {
3467 io_constraint (io_code && dt->namelist,
3468 "NAMELIST cannot be followed by IO-list at %L",
3469 &io_code->loc);
3470
3471 io_constraint (dt->format_expr,
3472 "IO spec-list cannot contain both NAMELIST group name "
f5c64803 3473 "and format specification at %L",
e0e85e06
PT		 3474 &dt->format_expr->where);
3475
3476 io_constraint (dt->format_label,
3477 "IO spec-list cannot contain both NAMELIST group name "
3478 "and format label at %L", spec_end);
3479
3480 io_constraint (dt->rec,
d06b3496 3481 "NAMELIST IO is not allowed with a REC= specifier "
f5c64803 3482 "at %L", &dt->rec->where);
e0e85e06
PT		 3483
3484 io_constraint (dt->advance,
d06b3496 3485 "NAMELIST IO is not allowed with a ADVANCE= specifier "
f5c64803 3486 "at %L", &dt->advance->where);
e0e85e06
PT		 3487 }
3488
3489 if (dt->rec)
3490 {
3491 io_constraint (dt->end,
3492 "An END tag is not allowed with a "
f5c64803 3493 "REC= specifier at %L", &dt->end_where);
e0e85e06 3494
e0e85e06 3495 io_constraint (dt->format_label == &format_asterisk,
d06b3496 3496 "FMT=* is not allowed with a REC= specifier "
f5c64803
JD		 3497 "at %L", spec_end);
3498
3499 io_constraint (dt->pos,
3500 "POS= is not allowed with REC= specifier "
3501 "at %L", &dt->pos->where);
e0e85e06
PT		 3502 }
3503
3504 if (dt->advance)
3505 {
e0e85e06
PT		 3506 int not_yes, not_no;
3507 expr = dt->advance;
e0e85e06
PT		 3508
3509 io_constraint (dt->format_label == &format_asterisk,
3510 "List directed format(*) is not allowed with a "
d06b3496 3511 "ADVANCE= specifier at %L.", &expr->where);
e0e85e06 3512
6f0f0b2e 3513 io_constraint (unformatted,
d06b3496 3514 "the ADVANCE= specifier at %L must appear with an "
b8ea6dbc
PT		 3515 "explicit format expression", &expr->where);
3516
8370d5bc
JJ		 3517 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3518 {
00660189
FXC		 3519 const gfc_char_t *advance = expr->value.character.string;
3520 not_no = gfc_wide_strlen (advance) != 2
3521 || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3522 not_yes = gfc_wide_strlen (advance) != 3
3523 || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
8370d5bc
JJ		 3524 }
3525 else
3526 {
3527 not_no = 0;
3528 not_yes = 0;
3529 }
e0e85e06 3530
8370d5bc 3531 io_constraint (not_no && not_yes,
d06b3496 3532 "ADVANCE= specifier at %L must have value = "
e0e85e06
PT		 3533 "YES or NO.", &expr->where);
3534
8370d5bc 3535 io_constraint (dt->size && not_no && k == M_READ,
e0e85e06
PT		 3536 "SIZE tag at %L requires an ADVANCE = 'NO'",
3537 &dt->size->where);
3538
8370d5bc 3539 io_constraint (dt->eor && not_no && k == M_READ,
e0e85e06
PT		 3540 "EOR tag at %L requires an ADVANCE = 'NO'",
3541 &dt->eor_where);
3542 }
3543
3544 expr = dt->format_expr;
524af0d6
JB		 3545 if (!gfc_simplify_expr (expr, 0)
3546 || !check_format_string (expr, k == M_READ))
2305fa31 3547 return MATCH_ERROR;
e0e85e06
PT		 3548
3549 return m;
3550}
3551#undef io_constraint
3552
b251af97 3553
6de9cd9a
DN		 3554/* Match a READ, WRITE or PRINT statement. */
3555
3556static match
3557match_io (io_kind k)
3558{
3559 char name[GFC_MAX_SYMBOL_LEN + 1];
3560 gfc_code *io_code;
3561 gfc_symbol *sym;
8fc541d3 3562 int comma_flag;
6de9cd9a 3563 locus where;
e0e85e06 3564 locus spec_end;
6de9cd9a
DN		 3565 gfc_dt *dt;
3566 match m;
3567
e0e85e06 3568 where = gfc_current_locus;
6de9cd9a 3569 comma_flag = 0;
ece3f663 3570 current_dt = dt = XCNEW (gfc_dt);
ff2c6bbb
SK		 3571 m = gfc_match_char ('(');
3572 if (m == MATCH_NO)
6de9cd9a 3573 {
7fd4d312 3574 where = gfc_current_locus;
08e1fe9e
TS		 3575 if (k == M_WRITE)
3576 goto syntax;
7fd4d312 3577 else if (k == M_PRINT)
7af8f00c 3578 {
08e1fe9e 3579 /* Treat the non-standard case of PRINT namelist. */
8fc541d3 3580 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
7fd4d312 3581 && gfc_match_name (name) == MATCH_YES)
7af8f00c 3582 {
7fd4d312
TS		 3583 gfc_find_symbol (name, NULL, 1, &sym);
3584 if (sym && sym->attr.flavor == FL_NAMELIST)
08e1fe9e 3585 {
524af0d6
JB		 3586 if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3587 "%C is an extension"))
7fd4d312
TS		 3588 {
3589 m = MATCH_ERROR;
3590 goto cleanup;
3591 }
7fd4d312
TS		 3592
3593 dt->io_unit = default_unit (k);
3594 dt->namelist = sym;
3595 goto get_io_list;
08e1fe9e 3596 }
7fd4d312
TS		 3597 else
3598 gfc_current_locus = where;
08e1fe9e 3599 }
7af8f00c
PT		 3600 }
3601
0ff0dfbf 3602 if (gfc_current_form == FORM_FREE)
7fd4d312 3603 {
8fc541d3 3604 char c = gfc_peek_ascii_char ();
7fd4d312
TS		 3605 if (c != ' ' && c != '*' && c != '\'' && c != '"')
3606 {
3607 m = MATCH_NO;
3608 goto cleanup;
3609 }
3610 }
0ff0dfbf 3611
6de9cd9a
DN		 3612 m = match_dt_format (dt);
3613 if (m == MATCH_ERROR)
3614 goto cleanup;
3615 if (m == MATCH_NO)
3616 goto syntax;
3617
3618 comma_flag = 1;
3619 dt->io_unit = default_unit (k);
3620 goto get_io_list;
3621 }
4d08533c
TK		 3622 else
3623 {
ff2c6bbb
SK		 3624 /* Before issuing an error for a malformed 'print (1,*)' type of
3625 error, check for a default-char-expr of the form ('(I0)'). */
ff2c6bbb
SK		 3626 if (k == M_PRINT && m == MATCH_YES)
3627 {
3628 /* Reset current locus to get the initial '(' in an expression. */
3629 gfc_current_locus = where;
3630 dt->format_expr = NULL;
3631 m = match_dt_format (dt);
3632
3633 if (m == MATCH_ERROR)
3634 goto cleanup;
3635 if (m == MATCH_NO || dt->format_expr == NULL)
3636 goto syntax;
3637
3638 comma_flag = 1;
3639 dt->io_unit = default_unit (k);
3640 goto get_io_list;
3641 }
4d08533c 3642 }
6de9cd9a
DN		 3643
3644 /* Match a control list */
3645 if (match_dt_element (k, dt) == MATCH_YES)
3646 goto next;
3647 if (match_dt_unit (k, dt) != MATCH_YES)
3648 goto loop;
3649
3650 if (gfc_match_char (')') == MATCH_YES)
3651 goto get_io_list;
3652 if (gfc_match_char (',') != MATCH_YES)
3653 goto syntax;
3654
3655 m = match_dt_element (k, dt);
3656 if (m == MATCH_YES)
3657 goto next;
3658 if (m == MATCH_ERROR)
3659 goto cleanup;
3660
3661 m = match_dt_format (dt);
3662 if (m == MATCH_YES)
3663 goto next;
3664 if (m == MATCH_ERROR)
3665 goto cleanup;
3666
63645982 3667 where = gfc_current_locus;
6de9cd9a 3668
7fd4d312
TS		 3669 m = gfc_match_name (name);
3670 if (m == MATCH_YES)
6de9cd9a 3671 {
7fd4d312
TS		 3672 gfc_find_symbol (name, NULL, 1, &sym);
3673 if (sym && sym->attr.flavor == FL_NAMELIST)
6de9cd9a 3674 {
7fd4d312
TS		 3675 dt->namelist = sym;
3676 if (k == M_READ && check_namelist (sym))
3677 {
3678 m = MATCH_ERROR;
3679 goto cleanup;
3680 }
3681 goto next;
6de9cd9a 3682 }
6de9cd9a
DN		 3683 }
3684
63645982 3685 gfc_current_locus = where;
6de9cd9a
DN		 3686
3687 goto loop; /* No matches, try regular elements */
3688
3689next:
3690 if (gfc_match_char (')') == MATCH_YES)
3691 goto get_io_list;
3692 if (gfc_match_char (',') != MATCH_YES)
3693 goto syntax;
3694
3695loop:
3696 for (;;)
3697 {
3698 m = match_dt_element (k, dt);
3699 if (m == MATCH_NO)
3700 goto syntax;
3701 if (m == MATCH_ERROR)
3702 goto cleanup;
3703
3704 if (gfc_match_char (')') == MATCH_YES)
3705 break;
3706 if (gfc_match_char (',') != MATCH_YES)
3707 goto syntax;
3708 }
3709
3710get_io_list:
e0e85e06
PT		 3711
3712 /* Used in check_io_constraints, where no locus is available. */
3713 spec_end = gfc_current_locus;
3714
8e8dc060
DK		 3715 /* Save the IO kind for later use. */
3716 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
3717
ad7ee6f8
JD		 3718 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3719 to save the locus. This is used later when resolving transfer statements
3720 that might have a format expression without unit number. */
3721 if (!comma_flag && gfc_match_char (',') == MATCH_YES)
8e8dc060 3722 dt->extra_comma = dt->dt_io_kind;
6de9cd9a
DN		 3723
3724 io_code = NULL;
3725 if (gfc_match_eos () != MATCH_YES)
3726 {
3727 if (comma_flag && gfc_match_char (',') != MATCH_YES)
3728 {
3729 gfc_error ("Expected comma in I/O list at %C");
3730 m = MATCH_ERROR;
3731 goto cleanup;
3732 }
3733
3734 m = match_io_list (k, &io_code);
3735 if (m == MATCH_ERROR)
3736 goto cleanup;
3737 if (m == MATCH_NO)
3738 goto syntax;
3739 }
3740
e0e85e06
PT		 3741 /* A full IO statement has been matched. Check the constraints. spec_end is
3742 supplied for cases where no locus is supplied. */
3743 m = check_io_constraints (k, dt, io_code, &spec_end);
6de9cd9a 3744
e0e85e06
PT		 3745 if (m == MATCH_ERROR)
3746 goto cleanup;
6de9cd9a
DN		 3747
3748 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3749 new_st.ext.dt = dt;
11e5274a 3750 new_st.block = gfc_get_code (new_st.op);
5e805e44 3751 new_st.block->next = io_code;
6de9cd9a
DN		 3752
3753 terminate_io (io_code);
3754
3755 return MATCH_YES;
3756
3757syntax:
3758 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3759 m = MATCH_ERROR;
3760
3761cleanup:
3762 gfc_free_dt (dt);
3763 return m;
3764}
3765
3766
3767match
3768gfc_match_read (void)
3769{
3770 return match_io (M_READ);
3771}
3772
6f0f0b2e 3773
6de9cd9a
DN		 3774match
3775gfc_match_write (void)
3776{
3777 return match_io (M_WRITE);
3778}
3779
6f0f0b2e 3780
6de9cd9a
DN		 3781match
3782gfc_match_print (void)
3783{
3784 match m;
3785
3786 m = match_io (M_PRINT);
3787 if (m != MATCH_YES)
3788 return m;
3789
3790 if (gfc_pure (NULL))
3791 {
3792 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3793 return MATCH_ERROR;
3794 }
3795
f1f39033
PT		 3796 if (gfc_implicit_pure (NULL))
3797 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3798
6de9cd9a
DN		 3799 return MATCH_YES;
3800}
3801
3802
3803/* Free a gfc_inquire structure. */
3804
3805void
b251af97 3806gfc_free_inquire (gfc_inquire *inquire)
6de9cd9a
DN		 3807{
3808
3809 if (inquire == NULL)
3810 return;
3811
3812 gfc_free_expr (inquire->unit);
3813 gfc_free_expr (inquire->file);
7aba8abe 3814 gfc_free_expr (inquire->iomsg);
6de9cd9a
DN		 3815 gfc_free_expr (inquire->iostat);
3816 gfc_free_expr (inquire->exist);
3817 gfc_free_expr (inquire->opened);
3818 gfc_free_expr (inquire->number);
3819 gfc_free_expr (inquire->named);
3820 gfc_free_expr (inquire->name);
3821 gfc_free_expr (inquire->access);
3822 gfc_free_expr (inquire->sequential);
3823 gfc_free_expr (inquire->direct);
3824 gfc_free_expr (inquire->form);
3825 gfc_free_expr (inquire->formatted);
3826 gfc_free_expr (inquire->unformatted);
3827 gfc_free_expr (inquire->recl);
3828 gfc_free_expr (inquire->nextrec);
3829 gfc_free_expr (inquire->blank);
3830 gfc_free_expr (inquire->position);
3831 gfc_free_expr (inquire->action);
3832 gfc_free_expr (inquire->read);
3833 gfc_free_expr (inquire->write);
3834 gfc_free_expr (inquire->readwrite);
3835 gfc_free_expr (inquire->delim);
d06b3496 3836 gfc_free_expr (inquire->encoding);
6de9cd9a
DN		 3837 gfc_free_expr (inquire->pad);
3838 gfc_free_expr (inquire->iolength);
181c9f4a 3839 gfc_free_expr (inquire->convert);
014ec6ee 3840 gfc_free_expr (inquire->strm_pos);
d06b3496 3841 gfc_free_expr (inquire->asynchronous);
e1456843 3842 gfc_free_expr (inquire->decimal);
d06b3496
JD		 3843 gfc_free_expr (inquire->pending);
3844 gfc_free_expr (inquire->id);
3845 gfc_free_expr (inquire->sign);
e1456843 3846 gfc_free_expr (inquire->size);
d06b3496 3847 gfc_free_expr (inquire->round);
cede9502 3848 free (inquire);
6de9cd9a
DN		 3849}
3850
3851
3852/* Match an element of an INQUIRE statement. */
3853
3854#define RETM if (m != MATCH_NO) return m;
3855
3856static match
b251af97 3857match_inquire_element (gfc_inquire *inquire)
6de9cd9a
DN		 3858{
3859 match m;
3860
3861 m = match_etag (&tag_unit, &inquire->unit);
3862 RETM m = match_etag (&tag_file, &inquire->file);
3863 RETM m = match_ltag (&tag_err, &inquire->err);
7aba8abe 3864 RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
c9583ed2 3865 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
6de9cd9a
DN		 3866 RETM m = match_vtag (&tag_exist, &inquire->exist);
3867 RETM m = match_vtag (&tag_opened, &inquire->opened);
3868 RETM m = match_vtag (&tag_named, &inquire->named);
3869 RETM m = match_vtag (&tag_name, &inquire->name);
c9583ed2 3870 RETM m = match_out_tag (&tag_number, &inquire->number);
6de9cd9a
DN		 3871 RETM m = match_vtag (&tag_s_access, &inquire->access);
3872 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3873 RETM m = match_vtag (&tag_direct, &inquire->direct);
3874 RETM m = match_vtag (&tag_s_form, &inquire->form);
3875 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3876 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
c9583ed2
TS		 3877 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3878 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
6de9cd9a
DN		 3879 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3880 RETM m = match_vtag (&tag_s_position, &inquire->position);
3881 RETM m = match_vtag (&tag_s_action, &inquire->action);
3882 RETM m = match_vtag (&tag_read, &inquire->read);
3883 RETM m = match_vtag (&tag_write, &inquire->write);
3884 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
d06b3496 3885 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
6de9cd9a 3886 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
d06b3496 3887 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
92867546 3888 RETM m = match_out_tag (&tag_size, &inquire->size);
d06b3496
JD		 3889 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3890 RETM m = match_vtag (&tag_s_round, &inquire->round);
3891 RETM m = match_vtag (&tag_s_sign, &inquire->sign);
6de9cd9a 3892 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
92867546 3893 RETM m = match_out_tag (&tag_iolength, &inquire->iolength);
181c9f4a 3894 RETM m = match_vtag (&tag_convert, &inquire->convert);
014ec6ee 3895 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
d06b3496
JD		 3896 RETM m = match_vtag (&tag_pending, &inquire->pending);
3897 RETM m = match_vtag (&tag_id, &inquire->id);
93e8af19 3898 RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
6de9cd9a
DN		 3899 RETM return MATCH_NO;
3900}
3901
3902#undef RETM
3903
3904
3905match
3906gfc_match_inquire (void)
3907{
3908 gfc_inquire *inquire;
3909 gfc_code *code;
3910 match m;
44998b65 3911 locus loc;
6de9cd9a
DN		 3912
3913 m = gfc_match_char ('(');
3914 if (m == MATCH_NO)
3915 return m;
3916
ece3f663 3917 inquire = XCNEW (gfc_inquire);
6de9cd9a 3918
44998b65
JB		 3919 loc = gfc_current_locus;
3920
6de9cd9a
DN		 3921 m = match_inquire_element (inquire);
3922 if (m == MATCH_ERROR)
3923 goto cleanup;
3924 if (m == MATCH_NO)
3925 {
3926 m = gfc_match_expr (&inquire->unit);
3927 if (m == MATCH_ERROR)
3928 goto cleanup;
3929 if (m == MATCH_NO)
3930 goto syntax;
3931 }
3932
3933 /* See if we have the IOLENGTH form of the inquire statement. */
3934 if (inquire->iolength != NULL)
3935 {
3936 if (gfc_match_char (')') != MATCH_YES)
3937 goto syntax;
3938
3939 m = match_io_list (M_INQUIRE, &code);
3940 if (m == MATCH_ERROR)
3941 goto cleanup;
3942 if (m == MATCH_NO)
3943 goto syntax;
3944
6de9cd9a 3945 new_st.op = EXEC_IOLENGTH;
a513927a 3946 new_st.expr1 = inquire->iolength;
8750f9cd 3947 new_st.ext.inquire = inquire;
6de9cd9a
DN		 3948
3949 if (gfc_pure (NULL))
3950 {
3951 gfc_free_statements (code);
3952 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3953 return MATCH_ERROR;
3954 }
3955
f1f39033
PT		 3956 if (gfc_implicit_pure (NULL))
3957 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3958
11e5274a 3959 new_st.block = gfc_get_code (EXEC_IOLENGTH);
5e805e44
JJ		 3960 terminate_io (code);
3961 new_st.block->next = code;
6de9cd9a
DN		 3962 return MATCH_YES;
3963 }
3964
3965 /* At this point, we have the non-IOLENGTH inquire statement. */
3966 for (;;)
3967 {
3968 if (gfc_match_char (')') == MATCH_YES)
3969 break;
3970 if (gfc_match_char (',') != MATCH_YES)
3971 goto syntax;
3972
3973 m = match_inquire_element (inquire);
3974 if (m == MATCH_ERROR)
3975 goto cleanup;
3976 if (m == MATCH_NO)
3977 goto syntax;
3978
3979 if (inquire->iolength != NULL)
3980 {
3981 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3982 goto cleanup;
3983 }
3984 }
3985
3986 if (gfc_match_eos () != MATCH_YES)
3987 goto syntax;
3988
44998b65
JB		 3989 if (inquire->unit != NULL && inquire->file != NULL)
3990 {
b251af97
SK		 3991 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3992 "UNIT specifiers", &loc);
44998b65
JB		 3993 goto cleanup;
3994 }
3995
3996 if (inquire->unit == NULL && inquire->file == NULL)
3997 {
b251af97
SK		 3998 gfc_error ("INQUIRE statement at %L requires either FILE or "
3999 "UNIT specifier", &loc);
44998b65
JB		 4000 goto cleanup;
4001 }
4002
6de9cd9a
DN		 4003 if (gfc_pure (NULL))
4004 {
4005 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4006 goto cleanup;
4007 }
f1f39033
PT		 4008
4009 if (gfc_implicit_pure (NULL))
4010 gfc_current_ns->proc_name->attr.implicit_pure = 0;
d06b3496
JD		 4011
4012 if (inquire->id != NULL && inquire->pending == NULL)
4013 {
4014 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4015 "the ID= specifier", &loc);
4016 goto cleanup;
4017 }
6de9cd9a
DN		 4018
4019 new_st.op = EXEC_INQUIRE;
4020 new_st.ext.inquire = inquire;
4021 return MATCH_YES;
4022
4023syntax:
4024 gfc_syntax_error (ST_INQUIRE);
4025
4026cleanup:
4027 gfc_free_inquire (inquire);
4028 return MATCH_ERROR;
4029}
4030
4031
4032/* Resolve everything in a gfc_inquire structure. */
4033
524af0d6 4034bool
b251af97 4035gfc_resolve_inquire (gfc_inquire *inquire)
6de9cd9a 4036{
6de9cd9a
DN		 4037 RESOLVE_TAG (&tag_unit, inquire->unit);
4038 RESOLVE_TAG (&tag_file, inquire->file);
d06b3496 4039 RESOLVE_TAG (&tag_id, inquire->id);
6de9cd9a 4040
8e8dc060
DK		 4041 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4042 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4043#define INQUIRE_RESOLVE_TAG(tag, expr) \
4044 RESOLVE_TAG (tag, expr); \
4045 if (expr) \
4046 { \
4047 char context[64]; \
4048 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
57bf28ea 4049 if (gfc_check_vardef_context ((expr), false, false, false, \
524af0d6
JB		 4050 context) == false) \
4051 return false; \
8e8dc060
DK		 4052 }
4053 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4054 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4055 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4056 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4057 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4058 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4059 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4060 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4061 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4062 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4063 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4064 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4065 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4066 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4067 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4068 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4069 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4070 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4071 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4072 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4073 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4074 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4075 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4076 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4077 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4078 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4079 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4080 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4081 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4082 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4083 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4084 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4085 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
75933b07 4086 INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
93e8af19 4087 INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
8e8dc060
DK		 4088#undef INQUIRE_RESOLVE_TAG
4089
524af0d6
JB		 4090 if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4091 return false;
6de9cd9a 4092
524af0d6 4093 return true;
6de9cd9a 4094}
6f0f0b2e
JD		 4095
4096
4097void
4098gfc_free_wait (gfc_wait *wait)
4099{
4100 if (wait == NULL)
4101 return;
4102
4103 gfc_free_expr (wait->unit);
4104 gfc_free_expr (wait->iostat);
4105 gfc_free_expr (wait->iomsg);
4106 gfc_free_expr (wait->id);
efb63364 4107 free (wait);
6f0f0b2e
JD		 4108}
4109
4110
524af0d6 4111bool
6f0f0b2e
JD		 4112gfc_resolve_wait (gfc_wait *wait)
4113{
4114 RESOLVE_TAG (&tag_unit, wait->unit);
4115 RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4116 RESOLVE_TAG (&tag_iostat, wait->iostat);
4117 RESOLVE_TAG (&tag_id, wait->id);
4118
524af0d6
JB		 4119 if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4120 return false;
6f0f0b2e 4121
524af0d6
JB		 4122 if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4123 return false;
6f0f0b2e 4124
524af0d6 4125 return true;
6f0f0b2e
JD		 4126}
4127
4128/* Match an element of a WAIT statement. */
4129
4130#define RETM if (m != MATCH_NO) return m;
4131
4132static match
4133match_wait_element (gfc_wait *wait)
4134{
4135 match m;
4136
4137 m = match_etag (&tag_unit, &wait->unit);
4138 RETM m = match_ltag (&tag_err, &wait->err);
4139 RETM m = match_ltag (&tag_end, &wait->eor);
4140 RETM m = match_ltag (&tag_eor, &wait->end);
4141 RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4142 RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4143 RETM m = match_etag (&tag_id, &wait->id);
4144 RETM return MATCH_NO;
4145}
4146
4147#undef RETM
4148
4149
4150match
4151gfc_match_wait (void)
4152{
4153 gfc_wait *wait;
4154 match m;
6f0f0b2e
JD		 4155
4156 m = gfc_match_char ('(');
4157 if (m == MATCH_NO)
4158 return m;
4159
ece3f663 4160 wait = XCNEW (gfc_wait);
6f0f0b2e 4161
6f0f0b2e
JD		 4162 m = match_wait_element (wait);
4163 if (m == MATCH_ERROR)
4164 goto cleanup;
4165 if (m == MATCH_NO)
4166 {
4167 m = gfc_match_expr (&wait->unit);
4168 if (m == MATCH_ERROR)
4169 goto cleanup;
4170 if (m == MATCH_NO)
4171 goto syntax;
4172 }
4173
4174 for (;;)
4175 {
4176 if (gfc_match_char (')') == MATCH_YES)
4177 break;
4178 if (gfc_match_char (',') != MATCH_YES)
4179 goto syntax;
4180
4181 m = match_wait_element (wait);
4182 if (m == MATCH_ERROR)
4183 goto cleanup;
4184 if (m == MATCH_NO)
4185 goto syntax;
4186 }
4187
524af0d6
JB		 4188 if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4189 "not allowed in Fortran 95"))
6f0f0b2e
JD		 4190 goto cleanup;
4191
4192 if (gfc_pure (NULL))
4193 {
4194 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4195 goto cleanup;
4196 }
4197
f1f39033
PT		 4198 if (gfc_implicit_pure (NULL))
4199 gfc_current_ns->proc_name->attr.implicit_pure = 0;
4200
6f0f0b2e
JD		 4201 new_st.op = EXEC_WAIT;
4202 new_st.ext.wait = wait;
4203
4204 return MATCH_YES;
4205
4206syntax:
4207 gfc_syntax_error (ST_WAIT);
4208
4209cleanup:
4210 gfc_free_wait (wait);
4211 return MATCH_ERROR;
4212}
Mirror of https://gcc.gnu.org/git/gcc.git