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