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