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