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