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