]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/io.c
projects / thirdparty / gcc.git / blob
? search:


979dfc20aa32b016d23f2d23746e7ae863735a51
[thirdparty/gcc.git] / gcc / fortran / io.c
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 const char *g0_precision = _("Specifying precision with G0 not allowed");
487
488 const char *error;
489 format_token t, u;
490 int level;
491 int repeat;
492 gfc_try rv;
493
494 use_last_char = 0;
495 saved_token = FMT_NONE;
496 level = 0;
497 repeat = 0;
498 rv = SUCCESS;
499
500 t = format_lex ();
501 if (t == FMT_ERROR)
502 goto fail;
503 if (t != FMT_LPAREN)
504 {
505 error = _("Missing leading left parenthesis");
506 goto syntax;
507 }
508
509 t = format_lex ();
510 if (t == FMT_ERROR)
511 goto fail;
512 if (t == FMT_RPAREN)
513 goto finished; /* Empty format is legal */
514 saved_token = t;
515
516 format_item:
517 /* In this state, the next thing has to be a format item. */
518 t = format_lex ();
519 if (t == FMT_ERROR)
520 goto fail;
521 format_item_1:
522 switch (t)
523 {
524 case FMT_POSINT:
525 repeat = value;
526 t = format_lex ();
527 if (t == FMT_ERROR)
528 goto fail;
529 if (t == FMT_LPAREN)
530 {
531 level++;
532 goto format_item;
533 }
534
535 if (t == FMT_SLASH)
536 goto optional_comma;
537
538 goto data_desc;
539
540 case FMT_LPAREN:
541 level++;
542 goto format_item;
543
544 case FMT_SIGNED_INT:
545 case FMT_ZERO:
546 /* Signed integer can only precede a P format. */
547 t = format_lex ();
548 if (t == FMT_ERROR)
549 goto fail;
550 if (t != FMT_P)
551 {
552 error = _("Expected P edit descriptor");
553 goto syntax;
554 }
555
556 goto data_desc;
557
558 case FMT_P:
559 /* P requires a prior number. */
560 error = _("P descriptor requires leading scale factor");
561 goto syntax;
562
563 case FMT_X:
564 /* X requires a prior number if we're being pedantic. */
565 if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
566 "requires leading space count at %C")
567 == FAILURE)
568 return FAILURE;
569 goto between_desc;
570
571 case FMT_SIGN:
572 case FMT_BLANK:
573 case FMT_DP:
574 case FMT_DC:
575 goto between_desc;
576
577 case FMT_CHAR:
578 goto extension_optional_comma;
579
580 case FMT_COLON:
581 case FMT_SLASH:
582 goto optional_comma;
583
584 case FMT_DOLLAR:
585 t = format_lex ();
586 if (t == FMT_ERROR)
587 goto fail;
588
589 if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
590 == FAILURE)
591 return FAILURE;
592 if (t != FMT_RPAREN || level > 0)
593 {
594 gfc_warning ("$ should be the last specifier in format at %C");
595 goto optional_comma_1;
596 }
597
598 goto finished;
599
600 case FMT_POS:
601 case FMT_IBOZ:
602 case FMT_F:
603 case FMT_E:
604 case FMT_EXT:
605 case FMT_G:
606 case FMT_L:
607 case FMT_A:
608 case FMT_D:
609 case FMT_H:
610 goto data_desc;
611
612 case FMT_END:
613 error = unexpected_end;
614 goto syntax;
615
616 default:
617 error = unexpected_element;
618 goto syntax;
619 }
620
621 data_desc:
622 /* In this state, t must currently be a data descriptor.
623 Deal with things that can/must follow the descriptor. */
624 switch (t)
625 {
626 case FMT_SIGN:
627 case FMT_BLANK:
628 case FMT_DP:
629 case FMT_DC:
630 case FMT_X:
631 break;
632
633 case FMT_P:
634 if (pedantic)
635 {
636 t = format_lex ();
637 if (t == FMT_ERROR)
638 goto fail;
639 if (t == FMT_POSINT)
640 {
641 error = _("Repeat count cannot follow P descriptor");
642 goto syntax;
643 }
644
645 saved_token = t;
646 }
647
648 goto optional_comma;
649
650 case FMT_POS:
651 case FMT_L:
652 t = format_lex ();
653 if (t == FMT_ERROR)
654 goto fail;
655 if (t == FMT_POSINT)
656 break;
657
658 switch (gfc_notification_std (GFC_STD_GNU))
659 {
660 case WARNING:
661 gfc_warning ("Extension: Missing positive width after L "
662 "descriptor at %C");
663 saved_token = t;
664 break;
665
666 case ERROR:
667 error = posint_required;
668 goto syntax;
669
670 case SILENT:
671 saved_token = t;
672 break;
673
674 default:
675 gcc_unreachable ();
676 }
677 break;
678
679 case FMT_A:
680 t = format_lex ();
681 if (t == FMT_ERROR)
682 goto fail;
683 if (t == FMT_ZERO)
684 {
685 error = zero_width;
686 goto syntax;
687 }
688 if (t != FMT_POSINT)
689 saved_token = t;
690 break;
691
692 case FMT_D:
693 case FMT_E:
694 case FMT_G:
695 case FMT_EXT:
696 u = format_lex ();
697 if (t == FMT_G && u == FMT_ZERO)
698 {
699 if (is_input)
700 {
701 error = zero_width;
702 goto syntax;
703 }
704
705 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
706 "format at %C") == FAILURE)
707 return FAILURE;
708
709 u = format_lex ();
710 if (u == FMT_PERIOD)
711 {
712 error = g0_precision;
713 goto syntax;
714 }
715 saved_token = u;
716 goto between_desc;
717 }
718
719 if (u == FMT_ERROR)
720 goto fail;
721 if (u != FMT_POSINT)
722 {
723 error = posint_required;
724 goto syntax;
725 }
726
727 u = format_lex ();
728 if (u == FMT_ERROR)
729 goto fail;
730 if (u != FMT_PERIOD)
731 {
732 /* Warn if -std=legacy, otherwise error. */
733 if (gfc_option.warn_std != 0)
734 gfc_error_now ("Period required in format specifier at %C");
735 else
736 gfc_warning ("Period required in format specifier at %C");
737 saved_token = u;
738 break;
739 }
740
741 u = format_lex ();
742 if (u == FMT_ERROR)
743 goto fail;
744 if (u != FMT_ZERO && u != FMT_POSINT)
745 {
746 error = nonneg_required;
747 goto syntax;
748 }
749
750 if (t == FMT_D)
751 break;
752
753 /* Look for optional exponent. */
754 u = format_lex ();
755 if (u == FMT_ERROR)
756 goto fail;
757 if (u != FMT_E)
758 {
759 saved_token = u;
760 }
761 else
762 {
763 u = format_lex ();
764 if (u == FMT_ERROR)
765 goto fail;
766 if (u != FMT_POSINT)
767 {
768 error = _("Positive exponent width required");
769 goto syntax;
770 }
771 }
772
773 break;
774
775 case FMT_F:
776 t = format_lex ();
777 if (t == FMT_ERROR)
778 goto fail;
779 if (t != FMT_ZERO && t != FMT_POSINT)
780 {
781 error = nonneg_required;
782 goto syntax;
783 }
784 else if (is_input && t == FMT_ZERO)
785 {
786 error = posint_required;
787 goto syntax;
788 }
789
790 t = format_lex ();
791 if (t == FMT_ERROR)
792 goto fail;
793 if (t != FMT_PERIOD)
794 {
795 /* Warn if -std=legacy, otherwise error. */
796 if (gfc_option.warn_std != 0)
797 gfc_error_now ("Period required in format specifier at %C");
798 else
799 gfc_warning ("Period required in format specifier at %C");
800 saved_token = t;
801 break;
802 }
803
804 t = format_lex ();
805 if (t == FMT_ERROR)
806 goto fail;
807 if (t != FMT_ZERO && t != FMT_POSINT)
808 {
809 error = nonneg_required;
810 goto syntax;
811 }
812
813 break;
814
815 case FMT_H:
816 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
817 gfc_warning ("The H format specifier at %C is"
818 " a Fortran 95 deleted feature");
819
820 if (mode == MODE_STRING)
821 {
822 format_string += value;
823 format_length -= value;
824 }
825 else
826 {
827 while (repeat >0)
828 {
829 next_char (1);
830 repeat -- ;
831 }
832 }
833 break;
834
835 case FMT_IBOZ:
836 t = format_lex ();
837 if (t == FMT_ERROR)
838 goto fail;
839 if (t != FMT_ZERO && t != FMT_POSINT)
840 {
841 error = nonneg_required;
842 goto syntax;
843 }
844 else if (is_input && t == FMT_ZERO)
845 {
846 error = posint_required;
847 goto syntax;
848 }
849
850 t = format_lex ();
851 if (t == FMT_ERROR)
852 goto fail;
853 if (t != FMT_PERIOD)
854 {
855 saved_token = t;
856 }
857 else
858 {
859 t = format_lex ();
860 if (t == FMT_ERROR)
861 goto fail;
862 if (t != FMT_ZERO && t != FMT_POSINT)
863 {
864 error = nonneg_required;
865 goto syntax;
866 }
867 }
868
869 break;
870
871 default:
872 error = unexpected_element;
873 goto syntax;
874 }
875
876 between_desc:
877 /* Between a descriptor and what comes next. */
878 t = format_lex ();
879 if (t == FMT_ERROR)
880 goto fail;
881 switch (t)
882 {
883
884 case FMT_COMMA:
885 goto format_item;
886
887 case FMT_RPAREN:
888 level--;
889 if (level < 0)
890 goto finished;
891 goto between_desc;
892
893 case FMT_COLON:
894 case FMT_SLASH:
895 goto optional_comma;
896
897 case FMT_END:
898 error = unexpected_end;
899 goto syntax;
900
901 default:
902 if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
903 == FAILURE)
904 return FAILURE;
905 goto format_item_1;
906 }
907
908 optional_comma:
909 /* Optional comma is a weird between state where we've just finished
910 reading a colon, slash, dollar or P descriptor. */
911 t = format_lex ();
912 if (t == FMT_ERROR)
913 goto fail;
914 optional_comma_1:
915 switch (t)
916 {
917 case FMT_COMMA:
918 break;
919
920 case FMT_RPAREN:
921 level--;
922 if (level < 0)
923 goto finished;
924 goto between_desc;
925
926 default:
927 /* Assume that we have another format item. */
928 saved_token = t;
929 break;
930 }
931
932 goto format_item;
933
934 extension_optional_comma:
935 /* As a GNU extension, permit a missing comma after a string literal. */
936 t = format_lex ();
937 if (t == FMT_ERROR)
938 goto fail;
939 switch (t)
940 {
941 case FMT_COMMA:
942 break;
943
944 case FMT_RPAREN:
945 level--;
946 if (level < 0)
947 goto finished;
948 goto between_desc;
949
950 case FMT_COLON:
951 case FMT_SLASH:
952 goto optional_comma;
953
954 case FMT_END:
955 error = unexpected_end;
956 goto syntax;
957
958 default:
959 if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
960 == FAILURE)
961 return FAILURE;
962 saved_token = t;
963 break;
964 }
965
966 goto format_item;
967
968 syntax:
969 if (error == unexpected_element)
970 gfc_error (error, error_element, &format_locus);
971 else
972 gfc_error ("%s in format string at %L", error, &format_locus);
973 fail:
974 rv = FAILURE;
975
976 finished:
977 return rv;
978 }
979
980
981 /* Given an expression node that is a constant string, see if it looks
982 like a format string. */
983
984 static gfc_try
985 check_format_string (gfc_expr *e, bool is_input)
986 {
987 if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
988 return SUCCESS;
989
990 mode = MODE_STRING;
991 format_string = e->value.character.string;
992
993 /* More elaborate measures are needed to show where a problem is within a
994 format string that has been calculated, but that's probably not worth the
995 effort. */
996 format_locus = e->where;
997
998 return check_format (is_input);
999 }
1000
1001
1002 /************ Fortran 95 I/O statement matchers *************/
1003
1004 /* Match a FORMAT statement. This amounts to actually parsing the
1005 format descriptors in order to correctly locate the end of the
1006 format string. */
1007
1008 match
1009 gfc_match_format (void)
1010 {
1011 gfc_expr *e;
1012 locus start;
1013
1014 if (gfc_current_ns->proc_name
1015 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
1016 {
1017 gfc_error ("Format statement in module main block at %C");
1018 return MATCH_ERROR;
1019 }
1020
1021 if (gfc_statement_label == NULL)
1022 {
1023 gfc_error ("Missing format label at %C");
1024 return MATCH_ERROR;
1025 }
1026 gfc_gobble_whitespace ();
1027
1028 mode = MODE_FORMAT;
1029 format_length = 0;
1030
1031 start = gfc_current_locus;
1032
1033 if (check_format (false) == FAILURE)
1034 return MATCH_ERROR;
1035
1036 if (gfc_match_eos () != MATCH_YES)
1037 {
1038 gfc_syntax_error (ST_FORMAT);
1039 return MATCH_ERROR;
1040 }
1041
1042 /* The label doesn't get created until after the statement is done
1043 being matched, so we have to leave the string for later. */
1044
1045 gfc_current_locus = start; /* Back to the beginning */
1046
1047 new_st.loc = start;
1048 new_st.op = EXEC_NOP;
1049
1050 e = gfc_get_expr();
1051 e->expr_type = EXPR_CONSTANT;
1052 e->ts.type = BT_CHARACTER;
1053 e->ts.kind = gfc_default_character_kind;
1054 e->where = start;
1055 e->value.character.string = format_string
1056 = gfc_get_wide_string (format_length + 1);
1057 e->value.character.length = format_length;
1058 gfc_statement_label->format = e;
1059
1060 mode = MODE_COPY;
1061 check_format (false); /* Guaranteed to succeed */
1062 gfc_match_eos (); /* Guaranteed to succeed */
1063
1064 return MATCH_YES;
1065 }
1066
1067
1068 /* Match an expression I/O tag of some sort. */
1069
1070 static match
1071 match_etag (const io_tag *tag, gfc_expr **v)
1072 {
1073 gfc_expr *result;
1074 match m;
1075
1076 m = gfc_match (tag->spec);
1077 if (m != MATCH_YES)
1078 return m;
1079
1080 m = gfc_match (tag->value, &result);
1081 if (m != MATCH_YES)
1082 {
1083 gfc_error ("Invalid value for %s specification at %C", tag->name);
1084 return MATCH_ERROR;
1085 }
1086
1087 if (*v != NULL)
1088 {
1089 gfc_error ("Duplicate %s specification at %C", tag->name);
1090 gfc_free_expr (result);
1091 return MATCH_ERROR;
1092 }
1093
1094 *v = result;
1095 return MATCH_YES;
1096 }
1097
1098
1099 /* Match a variable I/O tag of some sort. */
1100
1101 static match
1102 match_vtag (const io_tag *tag, gfc_expr **v)
1103 {
1104 gfc_expr *result;
1105 match m;
1106
1107 m = gfc_match (tag->spec);
1108 if (m != MATCH_YES)
1109 return m;
1110
1111 m = gfc_match (tag->value, &result);
1112 if (m != MATCH_YES)
1113 {
1114 gfc_error ("Invalid value for %s specification at %C", tag->name);
1115 return MATCH_ERROR;
1116 }
1117
1118 if (*v != NULL)
1119 {
1120 gfc_error ("Duplicate %s specification at %C", tag->name);
1121 gfc_free_expr (result);
1122 return MATCH_ERROR;
1123 }
1124
1125 if (result->symtree->n.sym->attr.intent == INTENT_IN)
1126 {
1127 gfc_error ("Variable tag cannot be INTENT(IN) at %C");
1128 gfc_free_expr (result);
1129 return MATCH_ERROR;
1130 }
1131
1132 if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1133 {
1134 gfc_error ("Variable tag cannot be assigned in PURE procedure at %C");
1135 gfc_free_expr (result);
1136 return MATCH_ERROR;
1137 }
1138
1139 *v = result;
1140 return MATCH_YES;
1141 }
1142
1143
1144 /* Match I/O tags that cause variables to become redefined. */
1145
1146 static match
1147 match_out_tag(const io_tag *tag, gfc_expr **result)
1148 {
1149 match m;
1150
1151 m = match_vtag(tag, result);
1152 if (m == MATCH_YES)
1153 gfc_check_do_variable((*result)->symtree);
1154
1155 return m;
1156 }
1157
1158
1159 /* Match a label I/O tag. */
1160
1161 static match
1162 match_ltag (const io_tag *tag, gfc_st_label ** label)
1163 {
1164 match m;
1165 gfc_st_label *old;
1166
1167 old = *label;
1168 m = gfc_match (tag->spec);
1169 if (m != MATCH_YES)
1170 return m;
1171
1172 m = gfc_match (tag->value, label);
1173 if (m != MATCH_YES)
1174 {
1175 gfc_error ("Invalid value for %s specification at %C", tag->name);
1176 return MATCH_ERROR;
1177 }
1178
1179 if (old)
1180 {
1181 gfc_error ("Duplicate %s label specification at %C", tag->name);
1182 return MATCH_ERROR;
1183 }
1184
1185 if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1186 return MATCH_ERROR;
1187
1188 return m;
1189 }
1190
1191
1192 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1193
1194 static gfc_try
1195 resolve_tag_format (const gfc_expr *e)
1196 {
1197 if (e->expr_type == EXPR_CONSTANT
1198 && (e->ts.type != BT_CHARACTER
1199 || e->ts.kind != gfc_default_character_kind))
1200 {
1201 gfc_error ("Constant expression in FORMAT tag at %L must be "
1202 "of type default CHARACTER", &e->where);
1203 return FAILURE;
1204 }
1205
1206 /* If e's rank is zero and e is not an element of an array, it should be
1207 of integer or character type. The integer variable should be
1208 ASSIGNED. */
1209 if (e->symtree == NULL || e->symtree->n.sym->as == NULL
1210 || e->symtree->n.sym->as->rank == 0)
1211 {
1212 if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1213 {
1214 gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1215 &e->where);
1216 return FAILURE;
1217 }
1218 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1219 {
1220 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1221 "variable in FORMAT tag at %L", &e->where)
1222 == FAILURE)
1223 return FAILURE;
1224 if (e->symtree->n.sym->attr.assign != 1)
1225 {
1226 gfc_error ("Variable '%s' at %L has not been assigned a "
1227 "format label", e->symtree->n.sym->name, &e->where);
1228 return FAILURE;
1229 }
1230 }
1231 else if (e->ts.type == BT_INTEGER)
1232 {
1233 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1234 "variable", gfc_basic_typename (e->ts.type), &e->where);
1235 return FAILURE;
1236 }
1237
1238 return SUCCESS;
1239 }
1240
1241 /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU
1242 and other type under GFC_STD_LEGACY. It may be assigned an Hollerith
1243 constant. */
1244 if (e->ts.type == BT_CHARACTER)
1245 {
1246 if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
1247 "in FORMAT tag at %L", &e->where) == FAILURE)
1248 return FAILURE;
1249 }
1250 else
1251 {
1252 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1253 "in FORMAT tag at %L", &e->where) == FAILURE)
1254 return FAILURE;
1255 }
1256
1257 return SUCCESS;
1258 }
1259
1260
1261 /* Do expression resolution and type-checking on an expression tag. */
1262
1263 static gfc_try
1264 resolve_tag (const io_tag *tag, gfc_expr *e)
1265 {
1266 if (e == NULL)
1267 return SUCCESS;
1268
1269 if (gfc_resolve_expr (e) == FAILURE)
1270 return FAILURE;
1271
1272 if (tag == &tag_format)
1273 return resolve_tag_format (e);
1274
1275 if (e->ts.type != tag->type)
1276 {
1277 gfc_error ("%s tag at %L must be of type %s", tag->name,
1278 &e->where, gfc_basic_typename (tag->type));
1279 return FAILURE;
1280 }
1281
1282 if (e->rank != 0)
1283 {
1284 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1285 return FAILURE;
1286 }
1287
1288 if (tag == &tag_iomsg)
1289 {
1290 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1291 &e->where) == FAILURE)
1292 return FAILURE;
1293 }
1294
1295 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1296 && e->ts.kind != gfc_default_integer_kind)
1297 {
1298 if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1299 "INTEGER in %s tag at %L", tag->name, &e->where)
1300 == FAILURE)
1301 return FAILURE;
1302 }
1303
1304 if (tag == &tag_convert)
1305 {
1306 if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1307 &e->where) == FAILURE)
1308 return FAILURE;
1309 }
1310
1311 return SUCCESS;
1312 }
1313
1314
1315 /* Match a single tag of an OPEN statement. */
1316
1317 static match
1318 match_open_element (gfc_open *open)
1319 {
1320 match m;
1321
1322 m = match_etag (&tag_e_async, &open->asynchronous);
1323 if (m != MATCH_NO)
1324 return m;
1325 m = match_etag (&tag_unit, &open->unit);
1326 if (m != MATCH_NO)
1327 return m;
1328 m = match_out_tag (&tag_iomsg, &open->iomsg);
1329 if (m != MATCH_NO)
1330 return m;
1331 m = match_out_tag (&tag_iostat, &open->iostat);
1332 if (m != MATCH_NO)
1333 return m;
1334 m = match_etag (&tag_file, &open->file);
1335 if (m != MATCH_NO)
1336 return m;
1337 m = match_etag (&tag_status, &open->status);
1338 if (m != MATCH_NO)
1339 return m;
1340 m = match_etag (&tag_e_access, &open->access);
1341 if (m != MATCH_NO)
1342 return m;
1343 m = match_etag (&tag_e_form, &open->form);
1344 if (m != MATCH_NO)
1345 return m;
1346 m = match_etag (&tag_e_recl, &open->recl);
1347 if (m != MATCH_NO)
1348 return m;
1349 m = match_etag (&tag_e_blank, &open->blank);
1350 if (m != MATCH_NO)
1351 return m;
1352 m = match_etag (&tag_e_position, &open->position);
1353 if (m != MATCH_NO)
1354 return m;
1355 m = match_etag (&tag_e_action, &open->action);
1356 if (m != MATCH_NO)
1357 return m;
1358 m = match_etag (&tag_e_delim, &open->delim);
1359 if (m != MATCH_NO)
1360 return m;
1361 m = match_etag (&tag_e_pad, &open->pad);
1362 if (m != MATCH_NO)
1363 return m;
1364 m = match_etag (&tag_e_decimal, &open->decimal);
1365 if (m != MATCH_NO)
1366 return m;
1367 m = match_etag (&tag_e_encoding, &open->encoding);
1368 if (m != MATCH_NO)
1369 return m;
1370 m = match_etag (&tag_e_round, &open->round);
1371 if (m != MATCH_NO)
1372 return m;
1373 m = match_etag (&tag_e_sign, &open->sign);
1374 if (m != MATCH_NO)
1375 return m;
1376 m = match_ltag (&tag_err, &open->err);
1377 if (m != MATCH_NO)
1378 return m;
1379 m = match_etag (&tag_convert, &open->convert);
1380 if (m != MATCH_NO)
1381 return m;
1382
1383 return MATCH_NO;
1384 }
1385
1386
1387 /* Free the gfc_open structure and all the expressions it contains. */
1388
1389 void
1390 gfc_free_open (gfc_open *open)
1391 {
1392 if (open == NULL)
1393 return;
1394
1395 gfc_free_expr (open->unit);
1396 gfc_free_expr (open->iomsg);
1397 gfc_free_expr (open->iostat);
1398 gfc_free_expr (open->file);
1399 gfc_free_expr (open->status);
1400 gfc_free_expr (open->access);
1401 gfc_free_expr (open->form);
1402 gfc_free_expr (open->recl);
1403 gfc_free_expr (open->blank);
1404 gfc_free_expr (open->position);
1405 gfc_free_expr (open->action);
1406 gfc_free_expr (open->delim);
1407 gfc_free_expr (open->pad);
1408 gfc_free_expr (open->decimal);
1409 gfc_free_expr (open->encoding);
1410 gfc_free_expr (open->round);
1411 gfc_free_expr (open->sign);
1412 gfc_free_expr (open->convert);
1413 gfc_free_expr (open->asynchronous);
1414 gfc_free (open);
1415 }
1416
1417
1418 /* Resolve everything in a gfc_open structure. */
1419
1420 gfc_try
1421 gfc_resolve_open (gfc_open *open)
1422 {
1423
1424 RESOLVE_TAG (&tag_unit, open->unit);
1425 RESOLVE_TAG (&tag_iomsg, open->iomsg);
1426 RESOLVE_TAG (&tag_iostat, open->iostat);
1427 RESOLVE_TAG (&tag_file, open->file);
1428 RESOLVE_TAG (&tag_status, open->status);
1429 RESOLVE_TAG (&tag_e_access, open->access);
1430 RESOLVE_TAG (&tag_e_form, open->form);
1431 RESOLVE_TAG (&tag_e_recl, open->recl);
1432 RESOLVE_TAG (&tag_e_blank, open->blank);
1433 RESOLVE_TAG (&tag_e_position, open->position);
1434 RESOLVE_TAG (&tag_e_action, open->action);
1435 RESOLVE_TAG (&tag_e_delim, open->delim);
1436 RESOLVE_TAG (&tag_e_pad, open->pad);
1437 RESOLVE_TAG (&tag_e_decimal, open->decimal);
1438 RESOLVE_TAG (&tag_e_encoding, open->encoding);
1439 RESOLVE_TAG (&tag_e_async, open->asynchronous);
1440 RESOLVE_TAG (&tag_e_round, open->round);
1441 RESOLVE_TAG (&tag_e_sign, open->sign);
1442 RESOLVE_TAG (&tag_convert, open->convert);
1443
1444 if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1445 return FAILURE;
1446
1447 return SUCCESS;
1448 }
1449
1450
1451 /* Check if a given value for a SPECIFIER is either in the list of values
1452 allowed in F95 or F2003, issuing an error message and returning a zero
1453 value if it is not allowed. */
1454
1455 static int
1456 compare_to_allowed_values (const char *specifier, const char *allowed[],
1457 const char *allowed_f2003[],
1458 const char *allowed_gnu[], gfc_char_t *value,
1459 const char *statement, bool warn)
1460 {
1461 int i;
1462 unsigned int len;
1463
1464 len = gfc_wide_strlen (value);
1465 if (len > 0)
1466 {
1467 for (len--; len > 0; len--)
1468 if (value[len] != ' ')
1469 break;
1470 len++;
1471 }
1472
1473 for (i = 0; allowed[i]; i++)
1474 if (len == strlen (allowed[i])
1475 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1476 return 1;
1477
1478 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1479 if (len == strlen (allowed_f2003[i])
1480 && gfc_wide_strncasecmp (value, allowed_f2003[i],
1481 strlen (allowed_f2003[i])) == 0)
1482 {
1483 notification n = gfc_notification_std (GFC_STD_F2003);
1484
1485 if (n == WARNING || (warn && n == ERROR))
1486 {
1487 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1488 "has value '%s'", specifier, statement,
1489 allowed_f2003[i]);
1490 return 1;
1491 }
1492 else
1493 if (n == ERROR)
1494 {
1495 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1496 "%s statement at %C has value '%s'", specifier,
1497 statement, allowed_f2003[i]);
1498 return 0;
1499 }
1500
1501 /* n == SILENT */
1502 return 1;
1503 }
1504
1505 for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1506 if (len == strlen (allowed_gnu[i])
1507 && gfc_wide_strncasecmp (value, allowed_gnu[i],
1508 strlen (allowed_gnu[i])) == 0)
1509 {
1510 notification n = gfc_notification_std (GFC_STD_GNU);
1511
1512 if (n == WARNING || (warn && n == ERROR))
1513 {
1514 gfc_warning ("Extension: %s specifier in %s statement at %C "
1515 "has value '%s'", specifier, statement,
1516 allowed_gnu[i]);
1517 return 1;
1518 }
1519 else
1520 if (n == ERROR)
1521 {
1522 gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1523 "%s statement at %C has value '%s'", specifier,
1524 statement, allowed_gnu[i]);
1525 return 0;
1526 }
1527
1528 /* n == SILENT */
1529 return 1;
1530 }
1531
1532 if (warn)
1533 {
1534 char *s = gfc_widechar_to_char (value, -1);
1535 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1536 specifier, statement, s);
1537 gfc_free (s);
1538 return 1;
1539 }
1540 else
1541 {
1542 char *s = gfc_widechar_to_char (value, -1);
1543 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1544 specifier, statement, s);
1545 gfc_free (s);
1546 return 0;
1547 }
1548 }
1549
1550
1551 /* Match an OPEN statement. */
1552
1553 match
1554 gfc_match_open (void)
1555 {
1556 gfc_open *open;
1557 match m;
1558 bool warn;
1559
1560 m = gfc_match_char ('(');
1561 if (m == MATCH_NO)
1562 return m;
1563
1564 open = XCNEW (gfc_open);
1565
1566 m = match_open_element (open);
1567
1568 if (m == MATCH_ERROR)
1569 goto cleanup;
1570 if (m == MATCH_NO)
1571 {
1572 m = gfc_match_expr (&open->unit);
1573 if (m == MATCH_NO)
1574 goto syntax;
1575 if (m == MATCH_ERROR)
1576 goto cleanup;
1577 }
1578
1579 for (;;)
1580 {
1581 if (gfc_match_char (')') == MATCH_YES)
1582 break;
1583 if (gfc_match_char (',') != MATCH_YES)
1584 goto syntax;
1585
1586 m = match_open_element (open);
1587 if (m == MATCH_ERROR)
1588 goto cleanup;
1589 if (m == MATCH_NO)
1590 goto syntax;
1591 }
1592
1593 if (gfc_match_eos () == MATCH_NO)
1594 goto syntax;
1595
1596 if (gfc_pure (NULL))
1597 {
1598 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1599 goto cleanup;
1600 }
1601
1602 warn = (open->err || open->iostat) ? true : false;
1603 /* Checks on the ACCESS specifier. */
1604 if (open->access && open->access->expr_type == EXPR_CONSTANT)
1605 {
1606 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1607 static const char *access_f2003[] = { "STREAM", NULL };
1608 static const char *access_gnu[] = { "APPEND", NULL };
1609
1610 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1611 access_gnu,
1612 open->access->value.character.string,
1613 "OPEN", warn))
1614 goto cleanup;
1615 }
1616
1617 /* Checks on the ACTION specifier. */
1618 if (open->action && open->action->expr_type == EXPR_CONSTANT)
1619 {
1620 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1621
1622 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1623 open->action->value.character.string,
1624 "OPEN", warn))
1625 goto cleanup;
1626 }
1627
1628 /* Checks on the ASYNCHRONOUS specifier. */
1629 if (open->asynchronous)
1630 {
1631 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
1632 "not allowed in Fortran 95") == FAILURE)
1633 goto cleanup;
1634
1635 if (open->asynchronous->expr_type == EXPR_CONSTANT)
1636 {
1637 static const char * asynchronous[] = { "YES", "NO", NULL };
1638
1639 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1640 NULL, NULL, open->asynchronous->value.character.string,
1641 "OPEN", warn))
1642 goto cleanup;
1643 }
1644 }
1645
1646 /* Checks on the BLANK specifier. */
1647 if (open->blank)
1648 {
1649 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
1650 "not allowed in Fortran 95") == FAILURE)
1651 goto cleanup;
1652
1653 if (open->blank->expr_type == EXPR_CONSTANT)
1654 {
1655 static const char *blank[] = { "ZERO", "NULL", NULL };
1656
1657 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1658 open->blank->value.character.string,
1659 "OPEN", warn))
1660 goto cleanup;
1661 }
1662 }
1663
1664 /* Checks on the DECIMAL specifier. */
1665 if (open->decimal)
1666 {
1667 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
1668 "not allowed in Fortran 95") == FAILURE)
1669 goto cleanup;
1670
1671 if (open->decimal->expr_type == EXPR_CONSTANT)
1672 {
1673 static const char * decimal[] = { "COMMA", "POINT", NULL };
1674
1675 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1676 open->decimal->value.character.string,
1677 "OPEN", warn))
1678 goto cleanup;
1679 }
1680 }
1681
1682 /* Checks on the DELIM specifier. */
1683 if (open->delim)
1684 {
1685 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1686 "not allowed in Fortran 95") == FAILURE)
1687 goto cleanup;
1688
1689 if (open->delim->expr_type == EXPR_CONSTANT)
1690 {
1691 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1692
1693 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1694 open->delim->value.character.string,
1695 "OPEN", warn))
1696 goto cleanup;
1697 }
1698 }
1699
1700 /* Checks on the ENCODING specifier. */
1701 if (open->encoding)
1702 {
1703 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1704 "not allowed in Fortran 95") == FAILURE)
1705 goto cleanup;
1706
1707 if (open->encoding->expr_type == EXPR_CONSTANT)
1708 {
1709 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1710
1711 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1712 open->encoding->value.character.string,
1713 "OPEN", warn))
1714 goto cleanup;
1715 }
1716 }
1717
1718 /* Checks on the FORM specifier. */
1719 if (open->form && open->form->expr_type == EXPR_CONSTANT)
1720 {
1721 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1722
1723 if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1724 open->form->value.character.string,
1725 "OPEN", warn))
1726 goto cleanup;
1727 }
1728
1729 /* Checks on the PAD specifier. */
1730 if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1731 {
1732 static const char *pad[] = { "YES", "NO", NULL };
1733
1734 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1735 open->pad->value.character.string,
1736 "OPEN", warn))
1737 goto cleanup;
1738 }
1739
1740 /* Checks on the POSITION specifier. */
1741 if (open->position && open->position->expr_type == EXPR_CONSTANT)
1742 {
1743 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
1744
1745 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
1746 open->position->value.character.string,
1747 "OPEN", warn))
1748 goto cleanup;
1749 }
1750
1751 /* Checks on the ROUND specifier. */
1752 if (open->round)
1753 {
1754 /* When implemented, change the following to use gfc_notify_std F2003. */
1755 gfc_error ("Fortran F2003: ROUND= specifier at %C not implemented");
1756 goto cleanup;
1757
1758 if (open->round->expr_type == EXPR_CONSTANT)
1759 {
1760 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
1761 "COMPATIBLE", "PROCESSOR_DEFINED",
1762 NULL };
1763
1764 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
1765 open->round->value.character.string,
1766 "OPEN", warn))
1767 goto cleanup;
1768 }
1769 }
1770
1771 /* Checks on the SIGN specifier. */
1772 if (open->sign)
1773 {
1774 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
1775 "not allowed in Fortran 95") == FAILURE)
1776 goto cleanup;
1777
1778 if (open->sign->expr_type == EXPR_CONSTANT)
1779 {
1780 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
1781 NULL };
1782
1783 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
1784 open->sign->value.character.string,
1785 "OPEN", warn))
1786 goto cleanup;
1787 }
1788 }
1789
1790 #define warn_or_error(...) \
1791 { \
1792 if (warn) \
1793 gfc_warning (__VA_ARGS__); \
1794 else \
1795 { \
1796 gfc_error (__VA_ARGS__); \
1797 goto cleanup; \
1798 } \
1799 }
1800
1801 /* Checks on the RECL specifier. */
1802 if (open->recl && open->recl->expr_type == EXPR_CONSTANT
1803 && open->recl->ts.type == BT_INTEGER
1804 && mpz_sgn (open->recl->value.integer) != 1)
1805 {
1806 warn_or_error ("RECL in OPEN statement at %C must be positive");
1807 }
1808
1809 /* Checks on the STATUS specifier. */
1810 if (open->status && open->status->expr_type == EXPR_CONSTANT)
1811 {
1812 static const char *status[] = { "OLD", "NEW", "SCRATCH",
1813 "REPLACE", "UNKNOWN", NULL };
1814
1815 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
1816 open->status->value.character.string,
1817 "OPEN", warn))
1818 goto cleanup;
1819
1820 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
1821 the FILE= specifier shall appear. */
1822 if (open->file == NULL
1823 && (gfc_wide_strncasecmp (open->status->value.character.string,
1824 "replace", 7) == 0
1825 || gfc_wide_strncasecmp (open->status->value.character.string,
1826 "new", 3) == 0))
1827 {
1828 char *s = gfc_widechar_to_char (open->status->value.character.string,
1829 -1);
1830 warn_or_error ("The STATUS specified in OPEN statement at %C is "
1831 "'%s' and no FILE specifier is present", s);
1832 gfc_free (s);
1833 }
1834
1835 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
1836 the FILE= specifier shall not appear. */
1837 if (gfc_wide_strncasecmp (open->status->value.character.string,
1838 "scratch", 7) == 0 && open->file)
1839 {
1840 warn_or_error ("The STATUS specified in OPEN statement at %C "
1841 "cannot have the value SCRATCH if a FILE specifier "
1842 "is present");
1843 }
1844 }
1845
1846 /* Things that are not allowed for unformatted I/O. */
1847 if (open->form && open->form->expr_type == EXPR_CONSTANT
1848 && (open->delim || open->decimal || open->encoding || open->round
1849 || open->sign || open->pad || open->blank)
1850 && gfc_wide_strncasecmp (open->form->value.character.string,
1851 "unformatted", 11) == 0)
1852 {
1853 const char *spec = (open->delim ? "DELIM "
1854 : (open->pad ? "PAD " : open->blank
1855 ? "BLANK " : ""));
1856
1857 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
1858 "unformatted I/O", spec);
1859 }
1860
1861 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
1862 && gfc_wide_strncasecmp (open->access->value.character.string,
1863 "stream", 6) == 0)
1864 {
1865 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
1866 "stream I/O");
1867 }
1868
1869 if (open->position
1870 && open->access && open->access->expr_type == EXPR_CONSTANT
1871 && !(gfc_wide_strncasecmp (open->access->value.character.string,
1872 "sequential", 10) == 0
1873 || gfc_wide_strncasecmp (open->access->value.character.string,
1874 "stream", 6) == 0
1875 || gfc_wide_strncasecmp (open->access->value.character.string,
1876 "append", 6) == 0))
1877 {
1878 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
1879 "for stream or sequential ACCESS");
1880 }
1881
1882 #undef warn_or_error
1883
1884 new_st.op = EXEC_OPEN;
1885 new_st.ext.open = open;
1886 return MATCH_YES;
1887
1888 syntax:
1889 gfc_syntax_error (ST_OPEN);
1890
1891 cleanup:
1892 gfc_free_open (open);
1893 return MATCH_ERROR;
1894 }
1895
1896
1897 /* Free a gfc_close structure an all its expressions. */
1898
1899 void
1900 gfc_free_close (gfc_close *close)
1901 {
1902 if (close == NULL)
1903 return;
1904
1905 gfc_free_expr (close->unit);
1906 gfc_free_expr (close->iomsg);
1907 gfc_free_expr (close->iostat);
1908 gfc_free_expr (close->status);
1909 gfc_free (close);
1910 }
1911
1912
1913 /* Match elements of a CLOSE statement. */
1914
1915 static match
1916 match_close_element (gfc_close *close)
1917 {
1918 match m;
1919
1920 m = match_etag (&tag_unit, &close->unit);
1921 if (m != MATCH_NO)
1922 return m;
1923 m = match_etag (&tag_status, &close->status);
1924 if (m != MATCH_NO)
1925 return m;
1926 m = match_out_tag (&tag_iomsg, &close->iomsg);
1927 if (m != MATCH_NO)
1928 return m;
1929 m = match_out_tag (&tag_iostat, &close->iostat);
1930 if (m != MATCH_NO)
1931 return m;
1932 m = match_ltag (&tag_err, &close->err);
1933 if (m != MATCH_NO)
1934 return m;
1935
1936 return MATCH_NO;
1937 }
1938
1939
1940 /* Match a CLOSE statement. */
1941
1942 match
1943 gfc_match_close (void)
1944 {
1945 gfc_close *close;
1946 match m;
1947 bool warn;
1948
1949 m = gfc_match_char ('(');
1950 if (m == MATCH_NO)
1951 return m;
1952
1953 close = XCNEW (gfc_close);
1954
1955 m = match_close_element (close);
1956
1957 if (m == MATCH_ERROR)
1958 goto cleanup;
1959 if (m == MATCH_NO)
1960 {
1961 m = gfc_match_expr (&close->unit);
1962 if (m == MATCH_NO)
1963 goto syntax;
1964 if (m == MATCH_ERROR)
1965 goto cleanup;
1966 }
1967
1968 for (;;)
1969 {
1970 if (gfc_match_char (')') == MATCH_YES)
1971 break;
1972 if (gfc_match_char (',') != MATCH_YES)
1973 goto syntax;
1974
1975 m = match_close_element (close);
1976 if (m == MATCH_ERROR)
1977 goto cleanup;
1978 if (m == MATCH_NO)
1979 goto syntax;
1980 }
1981
1982 if (gfc_match_eos () == MATCH_NO)
1983 goto syntax;
1984
1985 if (gfc_pure (NULL))
1986 {
1987 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
1988 goto cleanup;
1989 }
1990
1991 warn = (close->iostat || close->err) ? true : false;
1992
1993 /* Checks on the STATUS specifier. */
1994 if (close->status && close->status->expr_type == EXPR_CONSTANT)
1995 {
1996 static const char *status[] = { "KEEP", "DELETE", NULL };
1997
1998 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
1999 close->status->value.character.string,
2000 "CLOSE", warn))
2001 goto cleanup;
2002 }
2003
2004 new_st.op = EXEC_CLOSE;
2005 new_st.ext.close = close;
2006 return MATCH_YES;
2007
2008 syntax:
2009 gfc_syntax_error (ST_CLOSE);
2010
2011 cleanup:
2012 gfc_free_close (close);
2013 return MATCH_ERROR;
2014 }
2015
2016
2017 /* Resolve everything in a gfc_close structure. */
2018
2019 gfc_try
2020 gfc_resolve_close (gfc_close *close)
2021 {
2022 RESOLVE_TAG (&tag_unit, close->unit);
2023 RESOLVE_TAG (&tag_iomsg, close->iomsg);
2024 RESOLVE_TAG (&tag_iostat, close->iostat);
2025 RESOLVE_TAG (&tag_status, close->status);
2026
2027 if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2028 return FAILURE;
2029
2030 return SUCCESS;
2031 }
2032
2033
2034 /* Free a gfc_filepos structure. */
2035
2036 void
2037 gfc_free_filepos (gfc_filepos *fp)
2038 {
2039 gfc_free_expr (fp->unit);
2040 gfc_free_expr (fp->iomsg);
2041 gfc_free_expr (fp->iostat);
2042 gfc_free (fp);
2043 }
2044
2045
2046 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2047
2048 static match
2049 match_file_element (gfc_filepos *fp)
2050 {
2051 match m;
2052
2053 m = match_etag (&tag_unit, &fp->unit);
2054 if (m != MATCH_NO)
2055 return m;
2056 m = match_out_tag (&tag_iomsg, &fp->iomsg);
2057 if (m != MATCH_NO)
2058 return m;
2059 m = match_out_tag (&tag_iostat, &fp->iostat);
2060 if (m != MATCH_NO)
2061 return m;
2062 m = match_ltag (&tag_err, &fp->err);
2063 if (m != MATCH_NO)
2064 return m;
2065
2066 return MATCH_NO;
2067 }
2068
2069
2070 /* Match the second half of the file-positioning statements, REWIND,
2071 BACKSPACE, ENDFILE, or the FLUSH statement. */
2072
2073 static match
2074 match_filepos (gfc_statement st, gfc_exec_op op)
2075 {
2076 gfc_filepos *fp;
2077 match m;
2078
2079 fp = XCNEW (gfc_filepos);
2080
2081 if (gfc_match_char ('(') == MATCH_NO)
2082 {
2083 m = gfc_match_expr (&fp->unit);
2084 if (m == MATCH_ERROR)
2085 goto cleanup;
2086 if (m == MATCH_NO)
2087 goto syntax;
2088
2089 goto done;
2090 }
2091
2092 m = match_file_element (fp);
2093 if (m == MATCH_ERROR)
2094 goto done;
2095 if (m == MATCH_NO)
2096 {
2097 m = gfc_match_expr (&fp->unit);
2098 if (m == MATCH_ERROR)
2099 goto done;
2100 if (m == MATCH_NO)
2101 goto syntax;
2102 }
2103
2104 for (;;)
2105 {
2106 if (gfc_match_char (')') == MATCH_YES)
2107 break;
2108 if (gfc_match_char (',') != MATCH_YES)
2109 goto syntax;
2110
2111 m = match_file_element (fp);
2112 if (m == MATCH_ERROR)
2113 goto cleanup;
2114 if (m == MATCH_NO)
2115 goto syntax;
2116 }
2117
2118 done:
2119 if (gfc_match_eos () != MATCH_YES)
2120 goto syntax;
2121
2122 if (gfc_pure (NULL))
2123 {
2124 gfc_error ("%s statement not allowed in PURE procedure at %C",
2125 gfc_ascii_statement (st));
2126
2127 goto cleanup;
2128 }
2129
2130 new_st.op = op;
2131 new_st.ext.filepos = fp;
2132 return MATCH_YES;
2133
2134 syntax:
2135 gfc_syntax_error (st);
2136
2137 cleanup:
2138 gfc_free_filepos (fp);
2139 return MATCH_ERROR;
2140 }
2141
2142
2143 gfc_try
2144 gfc_resolve_filepos (gfc_filepos *fp)
2145 {
2146 RESOLVE_TAG (&tag_unit, fp->unit);
2147 RESOLVE_TAG (&tag_iostat, fp->iostat);
2148 RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2149 if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2150 return FAILURE;
2151
2152 return SUCCESS;
2153 }
2154
2155
2156 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2157 and the FLUSH statement. */
2158
2159 match
2160 gfc_match_endfile (void)
2161 {
2162 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2163 }
2164
2165 match
2166 gfc_match_backspace (void)
2167 {
2168 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2169 }
2170
2171 match
2172 gfc_match_rewind (void)
2173 {
2174 return match_filepos (ST_REWIND, EXEC_REWIND);
2175 }
2176
2177 match
2178 gfc_match_flush (void)
2179 {
2180 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2181 == FAILURE)
2182 return MATCH_ERROR;
2183
2184 return match_filepos (ST_FLUSH, EXEC_FLUSH);
2185 }
2186
2187 /******************** Data Transfer Statements *********************/
2188
2189 /* Return a default unit number. */
2190
2191 static gfc_expr *
2192 default_unit (io_kind k)
2193 {
2194 int unit;
2195
2196 if (k == M_READ)
2197 unit = 5;
2198 else
2199 unit = 6;
2200
2201 return gfc_int_expr (unit);
2202 }
2203
2204
2205 /* Match a unit specification for a data transfer statement. */
2206
2207 static match
2208 match_dt_unit (io_kind k, gfc_dt *dt)
2209 {
2210 gfc_expr *e;
2211
2212 if (gfc_match_char ('*') == MATCH_YES)
2213 {
2214 if (dt->io_unit != NULL)
2215 goto conflict;
2216
2217 dt->io_unit = default_unit (k);
2218 return MATCH_YES;
2219 }
2220
2221 if (gfc_match_expr (&e) == MATCH_YES)
2222 {
2223 if (dt->io_unit != NULL)
2224 {
2225 gfc_free_expr (e);
2226 goto conflict;
2227 }
2228
2229 dt->io_unit = e;
2230 return MATCH_YES;
2231 }
2232
2233 return MATCH_NO;
2234
2235 conflict:
2236 gfc_error ("Duplicate UNIT specification at %C");
2237 return MATCH_ERROR;
2238 }
2239
2240
2241 /* Match a format specification. */
2242
2243 static match
2244 match_dt_format (gfc_dt *dt)
2245 {
2246 locus where;
2247 gfc_expr *e;
2248 gfc_st_label *label;
2249 match m;
2250
2251 where = gfc_current_locus;
2252
2253 if (gfc_match_char ('*') == MATCH_YES)
2254 {
2255 if (dt->format_expr != NULL || dt->format_label != NULL)
2256 goto conflict;
2257
2258 dt->format_label = &format_asterisk;
2259 return MATCH_YES;
2260 }
2261
2262 if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2263 {
2264 if (dt->format_expr != NULL || dt->format_label != NULL)
2265 {
2266 gfc_free_st_label (label);
2267 goto conflict;
2268 }
2269
2270 if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2271 return MATCH_ERROR;
2272
2273 dt->format_label = label;
2274 return MATCH_YES;
2275 }
2276 else if (m == MATCH_ERROR)
2277 /* The label was zero or too large. Emit the correct diagnosis. */
2278 return MATCH_ERROR;
2279
2280 if (gfc_match_expr (&e) == MATCH_YES)
2281 {
2282 if (dt->format_expr != NULL || dt->format_label != NULL)
2283 {
2284 gfc_free_expr (e);
2285 goto conflict;
2286 }
2287 dt->format_expr = e;
2288 return MATCH_YES;
2289 }
2290
2291 gfc_current_locus = where; /* The only case where we have to restore */
2292
2293 return MATCH_NO;
2294
2295 conflict:
2296 gfc_error ("Duplicate format specification at %C");
2297 return MATCH_ERROR;
2298 }
2299
2300
2301 /* Traverse a namelist that is part of a READ statement to make sure
2302 that none of the variables in the namelist are INTENT(IN). Returns
2303 nonzero if we find such a variable. */
2304
2305 static int
2306 check_namelist (gfc_symbol *sym)
2307 {
2308 gfc_namelist *p;
2309
2310 for (p = sym->namelist; p; p = p->next)
2311 if (p->sym->attr.intent == INTENT_IN)
2312 {
2313 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2314 p->sym->name, sym->name);
2315 return 1;
2316 }
2317
2318 return 0;
2319 }
2320
2321
2322 /* Match a single data transfer element. */
2323
2324 static match
2325 match_dt_element (io_kind k, gfc_dt *dt)
2326 {
2327 char name[GFC_MAX_SYMBOL_LEN + 1];
2328 gfc_symbol *sym;
2329 match m;
2330
2331 if (gfc_match (" unit =") == MATCH_YES)
2332 {
2333 m = match_dt_unit (k, dt);
2334 if (m != MATCH_NO)
2335 return m;
2336 }
2337
2338 if (gfc_match (" fmt =") == MATCH_YES)
2339 {
2340 m = match_dt_format (dt);
2341 if (m != MATCH_NO)
2342 return m;
2343 }
2344
2345 if (gfc_match (" nml = %n", name) == MATCH_YES)
2346 {
2347 if (dt->namelist != NULL)
2348 {
2349 gfc_error ("Duplicate NML specification at %C");
2350 return MATCH_ERROR;
2351 }
2352
2353 if (gfc_find_symbol (name, NULL, 1, &sym))
2354 return MATCH_ERROR;
2355
2356 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2357 {
2358 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2359 sym != NULL ? sym->name : name);
2360 return MATCH_ERROR;
2361 }
2362
2363 dt->namelist = sym;
2364 if (k == M_READ && check_namelist (sym))
2365 return MATCH_ERROR;
2366
2367 return MATCH_YES;
2368 }
2369
2370 m = match_etag (&tag_e_async, &dt->asynchronous);
2371 if (m != MATCH_NO)
2372 return m;
2373 m = match_etag (&tag_e_blank, &dt->blank);
2374 if (m != MATCH_NO)
2375 return m;
2376 m = match_etag (&tag_e_delim, &dt->delim);
2377 if (m != MATCH_NO)
2378 return m;
2379 m = match_etag (&tag_e_pad, &dt->pad);
2380 if (m != MATCH_NO)
2381 return m;
2382 m = match_etag (&tag_e_sign, &dt->sign);
2383 if (m != MATCH_NO)
2384 return m;
2385 m = match_etag (&tag_e_round, &dt->round);
2386 if (m != MATCH_NO)
2387 return m;
2388 m = match_out_tag (&tag_id, &dt->id);
2389 if (m != MATCH_NO)
2390 return m;
2391 m = match_etag (&tag_e_decimal, &dt->decimal);
2392 if (m != MATCH_NO)
2393 return m;
2394 m = match_etag (&tag_rec, &dt->rec);
2395 if (m != MATCH_NO)
2396 return m;
2397 m = match_etag (&tag_spos, &dt->rec);
2398 if (m != MATCH_NO)
2399 return m;
2400 m = match_out_tag (&tag_iomsg, &dt->iomsg);
2401 if (m != MATCH_NO)
2402 return m;
2403 m = match_out_tag (&tag_iostat, &dt->iostat);
2404 if (m != MATCH_NO)
2405 return m;
2406 m = match_ltag (&tag_err, &dt->err);
2407 if (m == MATCH_YES)
2408 dt->err_where = gfc_current_locus;
2409 if (m != MATCH_NO)
2410 return m;
2411 m = match_etag (&tag_advance, &dt->advance);
2412 if (m != MATCH_NO)
2413 return m;
2414 m = match_out_tag (&tag_size, &dt->size);
2415 if (m != MATCH_NO)
2416 return m;
2417
2418 m = match_ltag (&tag_end, &dt->end);
2419 if (m == MATCH_YES)
2420 {
2421 if (k == M_WRITE)
2422 {
2423 gfc_error ("END tag at %C not allowed in output statement");
2424 return MATCH_ERROR;
2425 }
2426 dt->end_where = gfc_current_locus;
2427 }
2428 if (m != MATCH_NO)
2429 return m;
2430
2431 m = match_ltag (&tag_eor, &dt->eor);
2432 if (m == MATCH_YES)
2433 dt->eor_where = gfc_current_locus;
2434 if (m != MATCH_NO)
2435 return m;
2436
2437 return MATCH_NO;
2438 }
2439
2440
2441 /* Free a data transfer structure and everything below it. */
2442
2443 void
2444 gfc_free_dt (gfc_dt *dt)
2445 {
2446 if (dt == NULL)
2447 return;
2448
2449 gfc_free_expr (dt->io_unit);
2450 gfc_free_expr (dt->format_expr);
2451 gfc_free_expr (dt->rec);
2452 gfc_free_expr (dt->advance);
2453 gfc_free_expr (dt->iomsg);
2454 gfc_free_expr (dt->iostat);
2455 gfc_free_expr (dt->size);
2456 gfc_free_expr (dt->pad);
2457 gfc_free_expr (dt->delim);
2458 gfc_free_expr (dt->sign);
2459 gfc_free_expr (dt->round);
2460 gfc_free_expr (dt->blank);
2461 gfc_free_expr (dt->decimal);
2462 gfc_free_expr (dt->extra_comma);
2463 gfc_free (dt);
2464 }
2465
2466
2467 /* Resolve everything in a gfc_dt structure. */
2468
2469 gfc_try
2470 gfc_resolve_dt (gfc_dt *dt)
2471 {
2472 gfc_expr *e;
2473
2474 RESOLVE_TAG (&tag_format, dt->format_expr);
2475 RESOLVE_TAG (&tag_rec, dt->rec);
2476 RESOLVE_TAG (&tag_spos, dt->rec);
2477 RESOLVE_TAG (&tag_advance, dt->advance);
2478 RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2479 RESOLVE_TAG (&tag_iostat, dt->iostat);
2480 RESOLVE_TAG (&tag_size, dt->size);
2481 RESOLVE_TAG (&tag_e_pad, dt->pad);
2482 RESOLVE_TAG (&tag_e_delim, dt->delim);
2483 RESOLVE_TAG (&tag_e_sign, dt->sign);
2484 RESOLVE_TAG (&tag_e_round, dt->round);
2485 RESOLVE_TAG (&tag_e_blank, dt->blank);
2486 RESOLVE_TAG (&tag_e_decimal, dt->decimal);
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 https://gcc.gnu.org/git/gcc.git