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