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