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