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