OSDN Git Service

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