OSDN Git Service

2010-04-08 Bud Davis <bdavis9659@sbcglobal.net>
[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, 2007, 2008, 2009
3    Free Software 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 3, 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 COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22 #include "config.h"
23 #include "system.h"
24 #include "flags.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
28
29 gfc_st_label
30 format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
31                    0, {NULL, NULL}};
32
33 typedef struct
34 {
35   const char *name, *spec, *value;
36   bt type;
37 }
38 io_tag;
39
40 static const io_tag
41         tag_file        = {"FILE", " file =", " %e", BT_CHARACTER },
42         tag_status      = {"STATUS", " status =", " %e", BT_CHARACTER},
43         tag_e_access    = {"ACCESS", " access =", " %e", BT_CHARACTER},
44         tag_e_form      = {"FORM", " form =", " %e", BT_CHARACTER},
45         tag_e_recl      = {"RECL", " recl =", " %e", BT_INTEGER},
46         tag_e_blank     = {"BLANK", " blank =", " %e", BT_CHARACTER},
47         tag_e_position  = {"POSITION", " position =", " %e", BT_CHARACTER},
48         tag_e_action    = {"ACTION", " action =", " %e", BT_CHARACTER},
49         tag_e_delim     = {"DELIM", " delim =", " %e", BT_CHARACTER},
50         tag_e_pad       = {"PAD", " pad =", " %e", BT_CHARACTER},
51         tag_e_decimal   = {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
52         tag_e_encoding  = {"ENCODING", " encoding =", " %e", BT_CHARACTER},
53         tag_e_async     = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
54         tag_e_round     = {"ROUND", " round =", " %e", BT_CHARACTER},
55         tag_e_sign      = {"SIGN", " sign =", " %e", BT_CHARACTER},
56         tag_unit        = {"UNIT", " unit =", " %e", BT_INTEGER},
57         tag_advance     = {"ADVANCE", " advance =", " %e", BT_CHARACTER},
58         tag_rec         = {"REC", " rec =", " %e", BT_INTEGER},
59         tag_spos        = {"POSITION", " pos =", " %e", BT_INTEGER},
60         tag_format      = {"FORMAT", NULL, NULL, BT_CHARACTER},
61         tag_iomsg       = {"IOMSG", " iomsg =", " %e", BT_CHARACTER},
62         tag_iostat      = {"IOSTAT", " iostat =", " %v", BT_INTEGER},
63         tag_size        = {"SIZE", " size =", " %v", BT_INTEGER},
64         tag_exist       = {"EXIST", " exist =", " %v", BT_LOGICAL},
65         tag_opened      = {"OPENED", " opened =", " %v", BT_LOGICAL},
66         tag_named       = {"NAMED", " named =", " %v", BT_LOGICAL},
67         tag_name        = {"NAME", " name =", " %v", BT_CHARACTER},
68         tag_number      = {"NUMBER", " number =", " %v", BT_INTEGER},
69         tag_s_access    = {"ACCESS", " access =", " %v", BT_CHARACTER},
70         tag_sequential  = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER},
71         tag_direct      = {"DIRECT", " direct =", " %v", BT_CHARACTER},
72         tag_s_form      = {"FORM", " form =", " %v", BT_CHARACTER},
73         tag_formatted   = {"FORMATTED", " formatted =", " %v", BT_CHARACTER},
74         tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER},
75         tag_s_recl      = {"RECL", " recl =", " %v", BT_INTEGER},
76         tag_nextrec     = {"NEXTREC", " nextrec =", " %v", BT_INTEGER},
77         tag_s_blank     = {"BLANK", " blank =", " %v", BT_CHARACTER},
78         tag_s_position  = {"POSITION", " position =", " %v", BT_CHARACTER},
79         tag_s_action    = {"ACTION", " action =", " %v", BT_CHARACTER},
80         tag_read        = {"READ", " read =", " %v", BT_CHARACTER},
81         tag_write       = {"WRITE", " write =", " %v", BT_CHARACTER},
82         tag_readwrite   = {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
83         tag_s_delim     = {"DELIM", " delim =", " %v", BT_CHARACTER},
84         tag_s_pad       = {"PAD", " pad =", " %v", BT_CHARACTER},
85         tag_s_decimal   = {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
86         tag_s_encoding  = {"ENCODING", " encoding =", " %v", BT_CHARACTER},
87         tag_s_async     = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
88         tag_s_round     = {"ROUND", " round =", " %v", BT_CHARACTER},
89         tag_s_sign      = {"SIGN", " sign =", " %v", BT_CHARACTER},
90         tag_iolength    = {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
91         tag_convert     = {"CONVERT", " convert =", " %e", BT_CHARACTER},
92         tag_strm_out    = {"POS", " pos =", " %v", BT_INTEGER},
93         tag_err         = {"ERR", " err =", " %l", BT_UNKNOWN},
94         tag_end         = {"END", " end =", " %l", BT_UNKNOWN},
95         tag_eor         = {"EOR", " eor =", " %l", BT_UNKNOWN},
96         tag_id          = {"ID", " id =", " %v", BT_INTEGER},
97         tag_pending     = {"PENDING", " pending =", " %v", BT_LOGICAL},
98         tag_newunit     = {"NEWUNIT", " newunit =", " %v", BT_INTEGER};
99
100 static gfc_dt *current_dt;
101
102 #define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;
103
104
105 /**************** Fortran 95 FORMAT parser  *****************/
106
107 /* FORMAT tokens returned by format_lex().  */
108 typedef enum
109 {
110   FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
111   FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
112   FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
113   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
114   FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
115   FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
116 }
117 format_token;
118
119 /* Local variables for checking format strings.  The saved_token is
120    used to back up by a single format token during the parsing
121    process.  */
122 static gfc_char_t *format_string;
123 static int format_string_pos;
124 static int format_length, use_last_char;
125 static char error_element;
126 static locus format_locus;
127
128 static format_token saved_token;
129
130 static enum
131 { MODE_STRING, MODE_FORMAT, MODE_COPY }
132 mode;
133
134
135 /* Return the next character in the format string.  */
136
137 static char
138 next_char (int in_string)
139 {
140   static gfc_char_t c;
141
142   if (use_last_char)
143     {
144       use_last_char = 0;
145       return c;
146     }
147
148   format_length++;
149
150   if (mode == MODE_STRING)
151     c = *format_string++;
152   else
153     {
154       c = gfc_next_char_literal (in_string);
155       if (c == '\n')
156         c = '\0';
157     }
158
159   if (gfc_option.flag_backslash && c == '\\')
160     {
161       locus old_locus = gfc_current_locus;
162
163       if (gfc_match_special_char (&c) == MATCH_NO)
164         gfc_current_locus = old_locus;
165
166       if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
167         gfc_warning ("Extension: backslash character at %C");
168     }
169
170   if (mode == MODE_COPY)
171     *format_string++ = c;
172
173   if (mode != MODE_STRING)
174     format_locus = gfc_current_locus;
175
176   format_string_pos++;
177
178   c = gfc_wide_toupper (c);
179   return c;
180 }
181
182
183 /* Back up one character position.  Only works once.  */
184
185 static void
186 unget_char (void)
187 {
188   use_last_char = 1;
189 }
190
191 /* Eat up the spaces and return a character.  */
192
193 static char
194 next_char_not_space (bool *error)
195 {
196   char c;
197   do
198     {
199       error_element = c = next_char (0);
200       if (c == '\t')
201         {
202           if (gfc_option.allow_std & GFC_STD_GNU)
203             gfc_warning ("Extension: Tab character in format at %C");
204           else
205             {
206               gfc_error ("Extension: Tab character in format at %C");
207               *error = true;
208               return c;
209             }
210         }
211     }
212   while (gfc_is_whitespace (c));
213   return c;
214 }
215
216 static int value = 0;
217
218 /* Simple lexical analyzer for getting the next token in a FORMAT
219    statement.  */
220
221 static format_token
222 format_lex (void)
223 {
224   format_token token;
225   char c, delim;
226   int zflag;
227   int negative_flag;
228   bool error = false;
229
230   if (saved_token != FMT_NONE)
231     {
232       token = saved_token;
233       saved_token = FMT_NONE;
234       return token;
235     }
236
237   c = next_char_not_space (&error);
238   
239   negative_flag = 0;
240   switch (c)
241     {
242     case '-':
243       negative_flag = 1;
244     case '+':
245       c = next_char_not_space (&error);
246       if (!ISDIGIT (c))
247         {
248           token = FMT_UNKNOWN;
249           break;
250         }
251
252       value = c - '0';
253
254       do
255         {
256           c = next_char_not_space (&error);
257           if (ISDIGIT (c))
258             value = 10 * value + c - '0';
259         }
260       while (ISDIGIT (c));
261
262       unget_char ();
263
264       if (negative_flag)
265         value = -value;
266
267       token = FMT_SIGNED_INT;
268       break;
269
270     case '0':
271     case '1':
272     case '2':
273     case '3':
274     case '4':
275     case '5':
276     case '6':
277     case '7':
278     case '8':
279     case '9':
280       zflag = (c == '0');
281
282       value = c - '0';
283
284       do
285         {
286           c = next_char_not_space (&error);
287           if (ISDIGIT (c))
288             {
289               value = 10 * value + c - '0';
290               if (c != '0')
291                 zflag = 0;
292             }
293         }
294       while (ISDIGIT (c));
295
296       unget_char ();
297       token = zflag ? FMT_ZERO : FMT_POSINT;
298       break;
299
300     case '.':
301       token = FMT_PERIOD;
302       break;
303
304     case ',':
305       token = FMT_COMMA;
306       break;
307
308     case ':':
309       token = FMT_COLON;
310       break;
311
312     case '/':
313       token = FMT_SLASH;
314       break;
315
316     case '$':
317       token = FMT_DOLLAR;
318       break;
319
320     case 'T':
321       c = next_char_not_space (&error);
322       switch (c)
323         {
324         case 'L':
325           token = FMT_TL;
326           break;
327         case 'R':
328           token = FMT_TR;
329           break;
330         default:
331           token = FMT_T;
332           unget_char ();
333         }
334       break;
335
336     case '(':
337       token = FMT_LPAREN;
338       break;
339
340     case ')':
341       token = FMT_RPAREN;
342       break;
343
344     case 'X':
345       token = FMT_X;
346       break;
347
348     case 'S':
349       c = next_char_not_space (&error);
350       if (c != 'P' && c != 'S')
351         unget_char ();
352
353       token = FMT_SIGN;
354       break;
355
356     case 'B':
357       c = next_char_not_space (&error);
358       if (c == 'N' || c == 'Z')
359         token = FMT_BLANK;
360       else
361         {
362           unget_char ();
363           token = FMT_IBOZ;
364         }
365
366       break;
367
368     case '\'':
369     case '"':
370       delim = c;
371
372       value = 0;
373
374       for (;;)
375         {
376           c = next_char (1);
377           if (c == '\0')
378             {
379               token = FMT_END;
380               break;
381             }
382
383           if (c == delim)
384             {
385               c = next_char (1);
386
387               if (c == '\0')
388                 {
389                   token = FMT_END;
390                   break;
391                 }
392
393               if (c != delim)
394                 {
395                   unget_char ();
396                   token = FMT_CHAR;
397                   break;
398                 }
399             }
400           value++;
401         }
402       break;
403
404     case 'P':
405       token = FMT_P;
406       break;
407
408     case 'I':
409     case 'O':
410     case 'Z':
411       token = FMT_IBOZ;
412       break;
413
414     case 'F':
415       token = FMT_F;
416       break;
417
418     case 'E':
419       c = next_char_not_space (&error);
420       if (c == 'N' )
421         token = FMT_EN;
422       else if (c == 'S')
423         token = FMT_ES;
424       else
425         {
426           token = FMT_E;
427           unget_char ();
428         }
429
430       break;
431
432     case 'G':
433       token = FMT_G;
434       break;
435
436     case 'H':
437       token = FMT_H;
438       break;
439
440     case 'L':
441       token = FMT_L;
442       break;
443
444     case 'A':
445       token = FMT_A;
446       break;
447
448     case 'D':
449       c = next_char_not_space (&error);
450       if (c == 'P')
451         {
452           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format "
453               "specifier not allowed at %C") == FAILURE)
454             return FMT_ERROR;
455           token = FMT_DP;
456         }
457       else if (c == 'C')
458         {
459           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format "
460               "specifier not allowed at %C") == FAILURE)
461             return FMT_ERROR;
462           token = FMT_DC;
463         }
464       else
465         {
466           token = FMT_D;
467           unget_char ();
468         }
469       break;
470
471     case 'R':
472       c = next_char_not_space (&error);
473       switch (c)
474         {
475         case 'C':
476           token = FMT_RC;
477           break;
478         case 'D':
479           token = FMT_RD;
480           break;
481         case 'N':
482           token = FMT_RN;
483           break;
484         case 'P':
485           token = FMT_RP;
486           break;
487         case 'U':
488           token = FMT_RU;
489           break;
490         case 'Z':
491           token = FMT_RZ;
492           break;
493         default:
494           token = FMT_UNKNOWN;
495           unget_char ();
496           break;
497         }
498       break;
499
500     case '\0':
501       token = FMT_END;
502       break;
503
504     case '*':
505       token = FMT_STAR;
506       break;
507
508     default:
509       token = FMT_UNKNOWN;
510       break;
511     }
512
513   if (error)
514     return FMT_ERROR;
515
516   return token;
517 }
518
519
520 static const char *
521 token_to_string (format_token t)
522 {
523   switch (t)
524     {
525       case FMT_D:
526         return "D";
527       case FMT_G:
528         return "G";
529       case FMT_E:
530         return "E";
531       case FMT_EN:
532         return "EN";
533       case FMT_ES:
534         return "ES";
535       default:
536         return "";
537     }
538 }
539
540 /* Check a format statement.  The format string, either from a FORMAT
541    statement or a constant in an I/O statement has already been parsed
542    by itself, and we are checking it for validity.  The dual origin
543    means that the warning message is a little less than great.  */
544
545 static gfc_try
546 check_format (bool is_input)
547 {
548   const char *posint_required     = _("Positive width required");
549   const char *nonneg_required     = _("Nonnegative width required");
550   const char *unexpected_element  = _("Unexpected element '%c' in format string"
551                                       " at %L");
552   const char *unexpected_end      = _("Unexpected end of format string");
553   const char *zero_width          = _("Zero width in format descriptor");
554
555   const char *error;
556   format_token t, u;
557   int level;
558   int repeat;
559   gfc_try rv;
560
561   use_last_char = 0;
562   saved_token = FMT_NONE;
563   level = 0;
564   repeat = 0;
565   rv = SUCCESS;
566   format_string_pos = 0;
567
568   t = format_lex ();
569   if (t == FMT_ERROR)
570     goto fail;
571   if (t != FMT_LPAREN)
572     {
573       error = _("Missing leading left parenthesis");
574       goto syntax;
575     }
576
577   t = format_lex ();
578   if (t == FMT_ERROR)
579     goto fail;
580   if (t == FMT_RPAREN)
581     goto finished;              /* Empty format is legal */
582   saved_token = t;
583
584 format_item:
585   /* In this state, the next thing has to be a format item.  */
586   t = format_lex ();
587   if (t == FMT_ERROR)
588     goto fail;
589 format_item_1:
590   switch (t)
591     {
592     case FMT_STAR:
593       repeat = -1;
594       t = format_lex ();
595       if (t == FMT_ERROR)
596         goto fail;
597       if (t == FMT_LPAREN)
598         {
599           level++;
600           goto format_item;
601         }
602       error = _("Left parenthesis required after '*'");
603       goto syntax;
604
605     case FMT_POSINT:
606       repeat = value;
607       t = format_lex ();
608       if (t == FMT_ERROR)
609         goto fail;
610       if (t == FMT_LPAREN)
611         {
612           level++;
613           goto format_item;
614         }
615
616       if (t == FMT_SLASH)
617         goto optional_comma;
618
619       goto data_desc;
620
621     case FMT_LPAREN:
622       level++;
623       goto format_item;
624
625     case FMT_SIGNED_INT:
626     case FMT_ZERO:
627       /* Signed integer can only precede a P format.  */
628       t = format_lex ();
629       if (t == FMT_ERROR)
630         goto fail;
631       if (t != FMT_P)
632         {
633           error = _("Expected P edit descriptor");
634           goto syntax;
635         }
636
637       goto data_desc;
638
639     case FMT_P:
640       /* P requires a prior number.  */
641       error = _("P descriptor requires leading scale factor");
642       goto syntax;
643
644     case FMT_X:
645       /* X requires a prior number if we're being pedantic.  */
646       if (mode != MODE_FORMAT)
647         format_locus.nextc += format_string_pos;
648       if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
649                           "requires leading space count at %L", &format_locus)
650           == FAILURE)
651         return FAILURE;
652       goto between_desc;
653
654     case FMT_SIGN:
655     case FMT_BLANK:
656     case FMT_DP:
657     case FMT_DC:
658     case FMT_RC:
659     case FMT_RD:
660     case FMT_RN:
661     case FMT_RP:
662     case FMT_RU:
663     case FMT_RZ:
664       goto between_desc;
665
666     case FMT_CHAR:
667       goto extension_optional_comma;
668
669     case FMT_COLON:
670     case FMT_SLASH:
671       goto optional_comma;
672
673     case FMT_DOLLAR:
674       t = format_lex ();
675       if (t == FMT_ERROR)
676         goto fail;
677
678       if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %L",
679           &format_locus) == FAILURE)
680         return FAILURE;
681       if (t != FMT_RPAREN || level > 0)
682         {
683           gfc_warning ("$ should be the last specifier in format at %L",
684                        &format_locus);
685           goto optional_comma_1;
686         }
687
688       goto finished;
689
690     case FMT_T:
691     case FMT_TL:
692     case FMT_TR:
693     case FMT_IBOZ:
694     case FMT_F:
695     case FMT_E:
696     case FMT_EN:
697     case FMT_ES:
698     case FMT_G:
699     case FMT_L:
700     case FMT_A:
701     case FMT_D:
702     case FMT_H:
703       goto data_desc;
704
705     case FMT_END:
706       error = unexpected_end;
707       goto syntax;
708
709     default:
710       error = unexpected_element;
711       goto syntax;
712     }
713
714 data_desc:
715   /* In this state, t must currently be a data descriptor.
716      Deal with things that can/must follow the descriptor.  */
717   switch (t)
718     {
719     case FMT_SIGN:
720     case FMT_BLANK:
721     case FMT_DP:
722     case FMT_DC:
723     case FMT_X:
724       break;
725
726     case FMT_P:
727       /* No comma after P allowed only for F, E, EN, ES, D, or G.
728          10.1.1 (1).  */
729       t = format_lex ();
730       if (t == FMT_ERROR)
731         goto fail;
732       if (gfc_option.allow_std < GFC_STD_F2003 && t != FMT_COMMA
733           && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
734           && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
735         {
736           error = _("Comma required after P descriptor");
737           goto syntax;
738         }
739       if (t != FMT_COMMA)
740         {
741           if (t == FMT_POSINT)
742             {
743               t = format_lex ();
744               if (t == FMT_ERROR)
745                 goto fail;
746             }
747           if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D
748               && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
749             {
750               error = _("Comma required after P descriptor");
751               goto syntax;
752             }
753         }
754
755       saved_token = t;
756       goto optional_comma;
757
758     case FMT_T:
759     case FMT_TL:
760     case FMT_TR:
761       t = format_lex ();
762       if (t != FMT_POSINT)
763         {
764           error = _("Positive width required with T descriptor");
765           goto syntax;
766         }
767       break;
768
769     case FMT_L:
770       t = format_lex ();
771       if (t == FMT_ERROR)
772         goto fail;
773       if (t == FMT_POSINT)
774         break;
775
776       switch (gfc_notification_std (GFC_STD_GNU))
777         {
778           case WARNING:
779             if (mode != MODE_FORMAT)
780               format_locus.nextc += format_string_pos;
781             gfc_warning ("Extension: Missing positive width after L "
782                          "descriptor at %L", &format_locus);
783             saved_token = t;
784             break;
785
786           case ERROR:
787             error = posint_required;
788             goto syntax;
789
790           case SILENT:
791             saved_token = t;
792             break;
793
794           default:
795             gcc_unreachable ();
796         }
797       break;
798
799     case FMT_A:
800       t = format_lex ();
801       if (t == FMT_ERROR)
802         goto fail;
803       if (t == FMT_ZERO)
804         {
805           error = zero_width;
806           goto syntax;
807         }
808       if (t != FMT_POSINT)
809         saved_token = t;
810       break;
811
812     case FMT_D:
813     case FMT_E:
814     case FMT_G:
815     case FMT_EN:
816     case FMT_ES:
817       u = format_lex ();
818       if (t == FMT_G && u == FMT_ZERO)
819         {
820           if (is_input)
821             {
822               error = zero_width;
823               goto syntax;
824             }
825           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
826                               "format at %L", &format_locus) == FAILURE)
827             return FAILURE;
828           u = format_lex ();
829           if (u != FMT_PERIOD)
830             {
831               saved_token = u;
832               break;
833             }
834           u = format_lex ();
835           if (u != FMT_POSINT)
836             {
837               error = posint_required;
838               goto syntax;
839             }
840           u = format_lex ();
841           if (u == FMT_E)
842             {
843               error = _("E specifier not allowed with g0 descriptor");
844               goto syntax;
845             }
846           saved_token = u;
847           break;
848         }
849
850       if (u != FMT_POSINT)
851         {
852           format_locus.nextc += format_string_pos;
853           gfc_error ("Positive width required in format "
854                          "specifier %s at %L", token_to_string (t),
855                          &format_locus);
856           saved_token = u;
857           goto fail;
858         }
859
860       u = format_lex ();
861       if (u == FMT_ERROR)
862         goto fail;
863       if (u != FMT_PERIOD)
864         {
865           /* Warn if -std=legacy, otherwise error.  */
866           format_locus.nextc += format_string_pos;
867           if (gfc_option.warn_std != 0)
868             {
869               gfc_error ("Period required in format "
870                              "specifier %s at %L", token_to_string (t),
871                              &format_locus);
872               saved_token = u;
873               goto fail;
874             }
875           else
876             gfc_warning ("Period required in format "
877                          "specifier %s at %L", token_to_string (t),
878                           &format_locus);
879           /* If we go to finished, we need to unwind this
880              before the next round.  */
881           format_locus.nextc -= format_string_pos;
882           saved_token = u;
883           break;
884         }
885
886       u = format_lex ();
887       if (u == FMT_ERROR)
888         goto fail;
889       if (u != FMT_ZERO && u != FMT_POSINT)
890         {
891           error = nonneg_required;
892           goto syntax;
893         }
894
895       if (t == FMT_D)
896         break;
897
898       /* Look for optional exponent.  */
899       u = format_lex ();
900       if (u == FMT_ERROR)
901         goto fail;
902       if (u != FMT_E)
903         {
904           saved_token = u;
905         }
906       else
907         {
908           u = format_lex ();
909           if (u == FMT_ERROR)
910             goto fail;
911           if (u != FMT_POSINT)
912             {
913               error = _("Positive exponent width required");
914               goto syntax;
915             }
916         }
917
918       break;
919
920     case FMT_F:
921       t = format_lex ();
922       if (t == FMT_ERROR)
923         goto fail;
924       if (t != FMT_ZERO && t != FMT_POSINT)
925         {
926           error = nonneg_required;
927           goto syntax;
928         }
929       else if (is_input && t == FMT_ZERO)
930         {
931           error = posint_required;
932           goto syntax;
933         }
934
935       t = format_lex ();
936       if (t == FMT_ERROR)
937         goto fail;
938       if (t != FMT_PERIOD)
939         {
940           /* Warn if -std=legacy, otherwise error.  */
941           if (gfc_option.warn_std != 0)
942             {
943               error = _("Period required in format specifier");
944               goto syntax;
945             }
946           if (mode != MODE_FORMAT)
947             format_locus.nextc += format_string_pos;
948           gfc_warning ("Period required in format specifier at %L",
949                        &format_locus);
950           saved_token = t;
951           break;
952         }
953
954       t = format_lex ();
955       if (t == FMT_ERROR)
956         goto fail;
957       if (t != FMT_ZERO && t != FMT_POSINT)
958         {
959           error = nonneg_required;
960           goto syntax;
961         }
962
963       break;
964
965     case FMT_H:
966       if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
967         {
968           if (mode != MODE_FORMAT)
969             format_locus.nextc += format_string_pos;
970           gfc_warning ("The H format specifier at %L is"
971                        " a Fortran 95 deleted feature", &format_locus);
972         }
973       if (mode == MODE_STRING)
974         {
975           format_string += value;
976           format_length -= value;
977           format_string_pos += repeat;
978         }
979       else
980         {
981           while (repeat >0)
982            {
983              next_char (1);
984              repeat -- ;
985            }
986         }
987      break;
988
989     case FMT_IBOZ:
990       t = format_lex ();
991       if (t == FMT_ERROR)
992         goto fail;
993       if (t != FMT_ZERO && t != FMT_POSINT)
994         {
995           error = nonneg_required;
996           goto syntax;
997         }
998       else if (is_input && t == FMT_ZERO)
999         {
1000           error = posint_required;
1001           goto syntax;
1002         }
1003
1004       t = format_lex ();
1005       if (t == FMT_ERROR)
1006         goto fail;
1007       if (t != FMT_PERIOD)
1008         {
1009           saved_token = t;
1010         }
1011       else
1012         {
1013           t = format_lex ();
1014           if (t == FMT_ERROR)
1015             goto fail;
1016           if (t != FMT_ZERO && t != FMT_POSINT)
1017             {
1018               error = nonneg_required;
1019               goto syntax;
1020             }
1021         }
1022
1023       break;
1024
1025     default:
1026       error = unexpected_element;
1027       goto syntax;
1028     }
1029
1030 between_desc:
1031   /* Between a descriptor and what comes next.  */
1032   t = format_lex ();
1033   if (t == FMT_ERROR)
1034     goto fail;
1035   switch (t)
1036     {
1037
1038     case FMT_COMMA:
1039       goto format_item;
1040
1041     case FMT_RPAREN:
1042       level--;
1043       if (level < 0)
1044         goto finished;
1045       goto between_desc;
1046
1047     case FMT_COLON:
1048     case FMT_SLASH:
1049       goto optional_comma;
1050
1051     case FMT_END:
1052       error = unexpected_end;
1053       goto syntax;
1054
1055     default:
1056       if (mode != MODE_FORMAT)
1057         format_locus.nextc += format_string_pos - 1;
1058       if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
1059           &format_locus) == FAILURE)
1060         return FAILURE;
1061       /* If we do not actually return a failure, we need to unwind this
1062          before the next round.  */
1063       if (mode != MODE_FORMAT)
1064         format_locus.nextc -= format_string_pos;
1065       goto format_item_1;
1066     }
1067
1068 optional_comma:
1069   /* Optional comma is a weird between state where we've just finished
1070      reading a colon, slash, dollar or P descriptor.  */
1071   t = format_lex ();
1072   if (t == FMT_ERROR)
1073     goto fail;
1074 optional_comma_1:
1075   switch (t)
1076     {
1077     case FMT_COMMA:
1078       break;
1079
1080     case FMT_RPAREN:
1081       level--;
1082       if (level < 0)
1083         goto finished;
1084       goto between_desc;
1085
1086     default:
1087       /* Assume that we have another format item.  */
1088       saved_token = t;
1089       break;
1090     }
1091
1092   goto format_item;
1093
1094 extension_optional_comma:
1095   /* As a GNU extension, permit a missing comma after a string literal.  */
1096   t = format_lex ();
1097   if (t == FMT_ERROR)
1098     goto fail;
1099   switch (t)
1100     {
1101     case FMT_COMMA:
1102       break;
1103
1104     case FMT_RPAREN:
1105       level--;
1106       if (level < 0)
1107         goto finished;
1108       goto between_desc;
1109
1110     case FMT_COLON:
1111     case FMT_SLASH:
1112       goto optional_comma;
1113
1114     case FMT_END:
1115       error = unexpected_end;
1116       goto syntax;
1117
1118     default:
1119       if (mode != MODE_FORMAT)
1120         format_locus.nextc += format_string_pos;
1121       if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
1122           &format_locus) == FAILURE)
1123         return FAILURE;
1124       /* If we do not actually return a failure, we need to unwind this
1125          before the next round.  */
1126       if (mode != MODE_FORMAT)
1127         format_locus.nextc -= format_string_pos;
1128       saved_token = t;
1129       break;
1130     }
1131
1132   goto format_item;
1133   
1134 syntax:
1135   if (mode != MODE_FORMAT)
1136     format_locus.nextc += format_string_pos;
1137   if (error == unexpected_element)
1138     gfc_error (error, error_element, &format_locus);
1139   else
1140     gfc_error ("%s in format string at %L", error, &format_locus);
1141 fail:
1142   rv = FAILURE;
1143
1144 finished:
1145   return rv;
1146 }
1147
1148
1149 /* Given an expression node that is a constant string, see if it looks
1150    like a format string.  */
1151
1152 static gfc_try
1153 check_format_string (gfc_expr *e, bool is_input)
1154 {
1155   gfc_try rv;
1156   int i;
1157   if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1158     return SUCCESS;
1159
1160   mode = MODE_STRING;
1161   format_string = e->value.character.string;
1162
1163   /* More elaborate measures are needed to show where a problem is within a
1164      format string that has been calculated, but that's probably not worth the
1165      effort.  */
1166   format_locus = e->where;
1167   rv = check_format (is_input);
1168   /* check for extraneous characters at the end of an otherwise valid format
1169      string, like '(A10,I3)F5'
1170      start at the end and move back to the last character processed,
1171      spaces are OK */
1172   if (rv == SUCCESS && e->value.character.length > format_string_pos)
1173     for (i=e->value.character.length-1;i>format_string_pos-1;i--)
1174       if (e->value.character.string[i] != ' ')
1175         {
1176           format_locus.nextc += format_length + 1; 
1177           gfc_warning ("Extraneous characters in format at %L", &format_locus); 
1178           break;
1179         }
1180   return rv;
1181 }
1182
1183
1184 /************ Fortran 95 I/O statement matchers *************/
1185
1186 /* Match a FORMAT statement.  This amounts to actually parsing the
1187    format descriptors in order to correctly locate the end of the
1188    format string.  */
1189
1190 match
1191 gfc_match_format (void)
1192 {
1193   gfc_expr *e;
1194   locus start;
1195
1196   if (gfc_current_ns->proc_name
1197       && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
1198     {
1199       gfc_error ("Format statement in module main block at %C");
1200       return MATCH_ERROR;
1201     }
1202
1203   if (gfc_statement_label == NULL)
1204     {
1205       gfc_error ("Missing format label at %C");
1206       return MATCH_ERROR;
1207     }
1208   gfc_gobble_whitespace ();
1209
1210   mode = MODE_FORMAT;
1211   format_length = 0;
1212
1213   start = gfc_current_locus;
1214
1215   if (check_format (false) == FAILURE)
1216     return MATCH_ERROR;
1217
1218   if (gfc_match_eos () != MATCH_YES)
1219     {
1220       gfc_syntax_error (ST_FORMAT);
1221       return MATCH_ERROR;
1222     }
1223
1224   /* The label doesn't get created until after the statement is done
1225      being matched, so we have to leave the string for later.  */
1226
1227   gfc_current_locus = start;    /* Back to the beginning */
1228
1229   new_st.loc = start;
1230   new_st.op = EXEC_NOP;
1231
1232   e = gfc_get_expr();
1233   e->expr_type = EXPR_CONSTANT;
1234   e->ts.type = BT_CHARACTER;
1235   e->ts.kind = gfc_default_character_kind;
1236   e->where = start;
1237   e->value.character.string = format_string
1238                             = gfc_get_wide_string (format_length + 1);
1239   e->value.character.length = format_length;
1240   gfc_statement_label->format = e;
1241
1242   mode = MODE_COPY;
1243   check_format (false);         /* Guaranteed to succeed */
1244   gfc_match_eos ();             /* Guaranteed to succeed */
1245
1246   return MATCH_YES;
1247 }
1248
1249
1250 /* Match an expression I/O tag of some sort.  */
1251
1252 static match
1253 match_etag (const io_tag *tag, gfc_expr **v)
1254 {
1255   gfc_expr *result;
1256   match m;
1257
1258   m = gfc_match (tag->spec);
1259   if (m != MATCH_YES)
1260     return m;
1261
1262   m = gfc_match (tag->value, &result);
1263   if (m != MATCH_YES)
1264     {
1265       gfc_error ("Invalid value for %s specification at %C", tag->name);
1266       return MATCH_ERROR;
1267     }
1268
1269   if (*v != NULL)
1270     {
1271       gfc_error ("Duplicate %s specification at %C", tag->name);
1272       gfc_free_expr (result);
1273       return MATCH_ERROR;
1274     }
1275
1276   *v = result;
1277   return MATCH_YES;
1278 }
1279
1280
1281 /* Match a variable I/O tag of some sort.  */
1282
1283 static match
1284 match_vtag (const io_tag *tag, gfc_expr **v)
1285 {
1286   gfc_expr *result;
1287   match m;
1288
1289   m = gfc_match (tag->spec);
1290   if (m != MATCH_YES)
1291     return m;
1292
1293   m = gfc_match (tag->value, &result);
1294   if (m != MATCH_YES)
1295     {
1296       gfc_error ("Invalid value for %s specification at %C", tag->name);
1297       return MATCH_ERROR;
1298     }
1299
1300   if (*v != NULL)
1301     {
1302       gfc_error ("Duplicate %s specification at %C", tag->name);
1303       gfc_free_expr (result);
1304       return MATCH_ERROR;
1305     }
1306
1307   if (result->symtree->n.sym->attr.intent == INTENT_IN)
1308     {
1309       gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
1310       gfc_free_expr (result);
1311       return MATCH_ERROR;
1312     }
1313
1314   if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1315     {
1316       gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1317                  tag->name);
1318       gfc_free_expr (result);
1319       return MATCH_ERROR;
1320     }
1321
1322   *v = result;
1323   return MATCH_YES;
1324 }
1325
1326
1327 /* Match I/O tags that cause variables to become redefined.  */
1328
1329 static match
1330 match_out_tag (const io_tag *tag, gfc_expr **result)
1331 {
1332   match m;
1333
1334   m = match_vtag (tag, result);
1335   if (m == MATCH_YES)
1336     gfc_check_do_variable ((*result)->symtree);
1337
1338   return m;
1339 }
1340
1341
1342 /* Match a label I/O tag.  */
1343
1344 static match
1345 match_ltag (const io_tag *tag, gfc_st_label ** label)
1346 {
1347   match m;
1348   gfc_st_label *old;
1349
1350   old = *label;
1351   m = gfc_match (tag->spec);
1352   if (m != MATCH_YES)
1353     return m;
1354
1355   m = gfc_match (tag->value, label);
1356   if (m != MATCH_YES)
1357     {
1358       gfc_error ("Invalid value for %s specification at %C", tag->name);
1359       return MATCH_ERROR;
1360     }
1361
1362   if (old)
1363     {
1364       gfc_error ("Duplicate %s label specification at %C", tag->name);
1365       return MATCH_ERROR;
1366     }
1367
1368   if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1369     return MATCH_ERROR;
1370
1371   return m;
1372 }
1373
1374
1375 /* Resolution of the FORMAT tag, to be called from resolve_tag.  */
1376
1377 static gfc_try
1378 resolve_tag_format (const gfc_expr *e)
1379 {
1380   if (e->expr_type == EXPR_CONSTANT
1381       && (e->ts.type != BT_CHARACTER
1382           || e->ts.kind != gfc_default_character_kind))
1383     {
1384       gfc_error ("Constant expression in FORMAT tag at %L must be "
1385                  "of type default CHARACTER", &e->where);
1386       return FAILURE;
1387     }
1388
1389   /* If e's rank is zero and e is not an element of an array, it should be
1390      of integer or character type.  The integer variable should be
1391      ASSIGNED.  */
1392   if (e->rank == 0
1393       && (e->expr_type != EXPR_VARIABLE
1394           || e->symtree == NULL
1395           || e->symtree->n.sym->as == NULL
1396           || e->symtree->n.sym->as->rank == 0))
1397     {
1398       if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1399         {
1400           gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1401                      &e->where);
1402           return FAILURE;
1403         }
1404       else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1405         {
1406           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1407                               "variable in FORMAT tag at %L", &e->where)
1408               == FAILURE)
1409             return FAILURE;
1410           if (e->symtree->n.sym->attr.assign != 1)
1411             {
1412               gfc_error ("Variable '%s' at %L has not been assigned a "
1413                          "format label", e->symtree->n.sym->name, &e->where);
1414               return FAILURE;
1415             }
1416         }
1417       else if (e->ts.type == BT_INTEGER)
1418         {
1419           gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1420                      "variable", gfc_basic_typename (e->ts.type), &e->where);
1421           return FAILURE;
1422         }
1423
1424       return SUCCESS;
1425     }
1426
1427   /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1428      It may be assigned an Hollerith constant.  */
1429   if (e->ts.type != BT_CHARACTER)
1430     {
1431       if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1432                           "in FORMAT tag at %L", &e->where) == FAILURE)
1433         return FAILURE;
1434
1435       if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1436         {
1437           gfc_error ("Non-character assumed shape array element in FORMAT"
1438                      " tag at %L", &e->where);
1439           return FAILURE;
1440         }
1441
1442       if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1443         {
1444           gfc_error ("Non-character assumed size array element in FORMAT"
1445                      " tag at %L", &e->where);
1446           return FAILURE;
1447         }
1448
1449       if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1450         {
1451           gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1452                      &e->where);
1453           return FAILURE;
1454         }
1455     }
1456
1457   return SUCCESS;
1458 }
1459
1460
1461 /* Do expression resolution and type-checking on an expression tag.  */
1462
1463 static gfc_try
1464 resolve_tag (const io_tag *tag, gfc_expr *e)
1465 {
1466   if (e == NULL)
1467     return SUCCESS;
1468
1469   if (gfc_resolve_expr (e) == FAILURE)
1470     return FAILURE;
1471
1472   if (tag == &tag_format)
1473     return resolve_tag_format (e);
1474
1475   if (e->ts.type != tag->type)
1476     {
1477       gfc_error ("%s tag at %L must be of type %s", tag->name,
1478                  &e->where, gfc_basic_typename (tag->type));
1479       return FAILURE;
1480     }
1481
1482   if (e->rank != 0)
1483     {
1484       gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1485       return FAILURE;
1486     }
1487
1488   if (tag == &tag_iomsg)
1489     {
1490       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1491                           &e->where) == FAILURE)
1492         return FAILURE;
1493     }
1494
1495   if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1496       && e->ts.kind != gfc_default_integer_kind)
1497     {
1498       if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1499                           "INTEGER in %s tag at %L", tag->name, &e->where)
1500           == FAILURE)
1501         return FAILURE;
1502     }
1503
1504   if (tag == &tag_convert)
1505     {
1506       if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1507                           &e->where) == FAILURE)
1508         return FAILURE;
1509     }
1510   
1511   return SUCCESS;
1512 }
1513
1514
1515 /* Match a single tag of an OPEN statement.  */
1516
1517 static match
1518 match_open_element (gfc_open *open)
1519 {
1520   match m;
1521
1522   m = match_etag (&tag_e_async, &open->asynchronous);
1523   if (m != MATCH_NO)
1524     return m;
1525   m = match_etag (&tag_unit, &open->unit);
1526   if (m != MATCH_NO)
1527     return m;
1528   m = match_out_tag (&tag_iomsg, &open->iomsg);
1529   if (m != MATCH_NO)
1530     return m;
1531   m = match_out_tag (&tag_iostat, &open->iostat);
1532   if (m != MATCH_NO)
1533     return m;
1534   m = match_etag (&tag_file, &open->file);
1535   if (m != MATCH_NO)
1536     return m;
1537   m = match_etag (&tag_status, &open->status);
1538   if (m != MATCH_NO)
1539     return m;
1540   m = match_etag (&tag_e_access, &open->access);
1541   if (m != MATCH_NO)
1542     return m;
1543   m = match_etag (&tag_e_form, &open->form);
1544   if (m != MATCH_NO)
1545     return m;
1546   m = match_etag (&tag_e_recl, &open->recl);
1547   if (m != MATCH_NO)
1548     return m;
1549   m = match_etag (&tag_e_blank, &open->blank);
1550   if (m != MATCH_NO)
1551     return m;
1552   m = match_etag (&tag_e_position, &open->position);
1553   if (m != MATCH_NO)
1554     return m;
1555   m = match_etag (&tag_e_action, &open->action);
1556   if (m != MATCH_NO)
1557     return m;
1558   m = match_etag (&tag_e_delim, &open->delim);
1559   if (m != MATCH_NO)
1560     return m;
1561   m = match_etag (&tag_e_pad, &open->pad);
1562   if (m != MATCH_NO)
1563     return m;
1564   m = match_etag (&tag_e_decimal, &open->decimal);
1565   if (m != MATCH_NO)
1566     return m;
1567   m = match_etag (&tag_e_encoding, &open->encoding);
1568   if (m != MATCH_NO)
1569     return m;
1570   m = match_etag (&tag_e_round, &open->round);
1571   if (m != MATCH_NO)
1572     return m;
1573   m = match_etag (&tag_e_sign, &open->sign);
1574   if (m != MATCH_NO)
1575     return m;
1576   m = match_ltag (&tag_err, &open->err);
1577   if (m != MATCH_NO)
1578     return m;
1579   m = match_etag (&tag_convert, &open->convert);
1580   if (m != MATCH_NO)
1581     return m;
1582   m = match_out_tag (&tag_newunit, &open->newunit);
1583   if (m != MATCH_NO)
1584     return m;
1585
1586   return MATCH_NO;
1587 }
1588
1589
1590 /* Free the gfc_open structure and all the expressions it contains.  */
1591
1592 void
1593 gfc_free_open (gfc_open *open)
1594 {
1595   if (open == NULL)
1596     return;
1597
1598   gfc_free_expr (open->unit);
1599   gfc_free_expr (open->iomsg);
1600   gfc_free_expr (open->iostat);
1601   gfc_free_expr (open->file);
1602   gfc_free_expr (open->status);
1603   gfc_free_expr (open->access);
1604   gfc_free_expr (open->form);
1605   gfc_free_expr (open->recl);
1606   gfc_free_expr (open->blank);
1607   gfc_free_expr (open->position);
1608   gfc_free_expr (open->action);
1609   gfc_free_expr (open->delim);
1610   gfc_free_expr (open->pad);
1611   gfc_free_expr (open->decimal);
1612   gfc_free_expr (open->encoding);
1613   gfc_free_expr (open->round);
1614   gfc_free_expr (open->sign);
1615   gfc_free_expr (open->convert);
1616   gfc_free_expr (open->asynchronous);
1617   gfc_free_expr (open->newunit);
1618   gfc_free (open);
1619 }
1620
1621
1622 /* Resolve everything in a gfc_open structure.  */
1623
1624 gfc_try
1625 gfc_resolve_open (gfc_open *open)
1626 {
1627
1628   RESOLVE_TAG (&tag_unit, open->unit);
1629   RESOLVE_TAG (&tag_iomsg, open->iomsg);
1630   RESOLVE_TAG (&tag_iostat, open->iostat);
1631   RESOLVE_TAG (&tag_file, open->file);
1632   RESOLVE_TAG (&tag_status, open->status);
1633   RESOLVE_TAG (&tag_e_access, open->access);
1634   RESOLVE_TAG (&tag_e_form, open->form);
1635   RESOLVE_TAG (&tag_e_recl, open->recl);
1636   RESOLVE_TAG (&tag_e_blank, open->blank);
1637   RESOLVE_TAG (&tag_e_position, open->position);
1638   RESOLVE_TAG (&tag_e_action, open->action);
1639   RESOLVE_TAG (&tag_e_delim, open->delim);
1640   RESOLVE_TAG (&tag_e_pad, open->pad);
1641   RESOLVE_TAG (&tag_e_decimal, open->decimal);
1642   RESOLVE_TAG (&tag_e_encoding, open->encoding);
1643   RESOLVE_TAG (&tag_e_async, open->asynchronous);
1644   RESOLVE_TAG (&tag_e_round, open->round);
1645   RESOLVE_TAG (&tag_e_sign, open->sign);
1646   RESOLVE_TAG (&tag_convert, open->convert);
1647   RESOLVE_TAG (&tag_newunit, open->newunit);
1648
1649   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1650     return FAILURE;
1651
1652   return SUCCESS;
1653 }
1654
1655
1656 /* Check if a given value for a SPECIFIER is either in the list of values
1657    allowed in F95 or F2003, issuing an error message and returning a zero
1658    value if it is not allowed.  */
1659
1660 static int
1661 compare_to_allowed_values (const char *specifier, const char *allowed[],
1662                            const char *allowed_f2003[], 
1663                            const char *allowed_gnu[], gfc_char_t *value,
1664                            const char *statement, bool warn)
1665 {
1666   int i;
1667   unsigned int len;
1668
1669   len = gfc_wide_strlen (value);
1670   if (len > 0)
1671   {
1672     for (len--; len > 0; len--)
1673       if (value[len] != ' ')
1674         break;
1675     len++;
1676   }
1677
1678   for (i = 0; allowed[i]; i++)
1679     if (len == strlen (allowed[i])
1680         && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1681       return 1;
1682
1683   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1684     if (len == strlen (allowed_f2003[i])
1685         && gfc_wide_strncasecmp (value, allowed_f2003[i],
1686                                  strlen (allowed_f2003[i])) == 0)
1687       {
1688         notification n = gfc_notification_std (GFC_STD_F2003);
1689
1690         if (n == WARNING || (warn && n == ERROR))
1691           {
1692             gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1693                          "has value '%s'", specifier, statement,
1694                          allowed_f2003[i]);
1695             return 1;
1696           }
1697         else
1698           if (n == ERROR)
1699             {
1700               gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1701                               "%s statement at %C has value '%s'", specifier,
1702                               statement, allowed_f2003[i]);
1703               return 0;
1704             }
1705
1706         /* n == SILENT */
1707         return 1;
1708       }
1709
1710   for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1711     if (len == strlen (allowed_gnu[i])
1712         && gfc_wide_strncasecmp (value, allowed_gnu[i],
1713                                  strlen (allowed_gnu[i])) == 0)
1714       {
1715         notification n = gfc_notification_std (GFC_STD_GNU);
1716
1717         if (n == WARNING || (warn && n == ERROR))
1718           {
1719             gfc_warning ("Extension: %s specifier in %s statement at %C "
1720                          "has value '%s'", specifier, statement,
1721                          allowed_gnu[i]);
1722             return 1;
1723           }
1724         else
1725           if (n == ERROR)
1726             {
1727               gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1728                               "%s statement at %C has value '%s'", specifier,
1729                               statement, allowed_gnu[i]);
1730               return 0;
1731             }
1732
1733         /* n == SILENT */
1734         return 1;
1735       }
1736
1737   if (warn)
1738     {
1739       char *s = gfc_widechar_to_char (value, -1);
1740       gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1741                    specifier, statement, s);
1742       gfc_free (s);
1743       return 1;
1744     }
1745   else
1746     {
1747       char *s = gfc_widechar_to_char (value, -1);
1748       gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1749                  specifier, statement, s);
1750       gfc_free (s);
1751       return 0;
1752     }
1753 }
1754
1755
1756 /* Match an OPEN statement.  */
1757
1758 match
1759 gfc_match_open (void)
1760 {
1761   gfc_open *open;
1762   match m;
1763   bool warn;
1764
1765   m = gfc_match_char ('(');
1766   if (m == MATCH_NO)
1767     return m;
1768
1769   open = XCNEW (gfc_open);
1770
1771   m = match_open_element (open);
1772
1773   if (m == MATCH_ERROR)
1774     goto cleanup;
1775   if (m == MATCH_NO)
1776     {
1777       m = gfc_match_expr (&open->unit);
1778       if (m == MATCH_NO)
1779         goto syntax;
1780       if (m == MATCH_ERROR)
1781         goto cleanup;
1782     }
1783
1784   for (;;)
1785     {
1786       if (gfc_match_char (')') == MATCH_YES)
1787         break;
1788       if (gfc_match_char (',') != MATCH_YES)
1789         goto syntax;
1790
1791       m = match_open_element (open);
1792       if (m == MATCH_ERROR)
1793         goto cleanup;
1794       if (m == MATCH_NO)
1795         goto syntax;
1796     }
1797
1798   if (gfc_match_eos () == MATCH_NO)
1799     goto syntax;
1800
1801   if (gfc_pure (NULL))
1802     {
1803       gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1804       goto cleanup;
1805     }
1806
1807   warn = (open->err || open->iostat) ? true : false;
1808
1809   /* Checks on NEWUNIT specifier.  */
1810   if (open->newunit)
1811     {
1812       if (open->unit)
1813         {
1814           gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1815           goto cleanup;
1816         }
1817
1818       if (!(open->file || (open->status
1819           && gfc_wide_strncasecmp (open->status->value.character.string,
1820                                    "scratch", 7) == 0)))
1821         {
1822           gfc_error ("NEWUNIT specifier must have FILE= "
1823                      "or STATUS='scratch' at %C");
1824           goto cleanup;
1825         }
1826     }
1827
1828   /* Checks on the ACCESS specifier.  */
1829   if (open->access && open->access->expr_type == EXPR_CONSTANT)
1830     {
1831       static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1832       static const char *access_f2003[] = { "STREAM", NULL };
1833       static const char *access_gnu[] = { "APPEND", NULL };
1834
1835       if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1836                                       access_gnu,
1837                                       open->access->value.character.string,
1838                                       "OPEN", warn))
1839         goto cleanup;
1840     }
1841
1842   /* Checks on the ACTION specifier.  */
1843   if (open->action && open->action->expr_type == EXPR_CONSTANT)
1844     {
1845       static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1846
1847       if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1848                                       open->action->value.character.string,
1849                                       "OPEN", warn))
1850         goto cleanup;
1851     }
1852
1853   /* Checks on the ASYNCHRONOUS specifier.  */
1854   if (open->asynchronous)
1855     {
1856       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
1857           "not allowed in Fortran 95") == FAILURE)
1858         goto cleanup;
1859
1860       if (open->asynchronous->expr_type == EXPR_CONSTANT)
1861         {
1862           static const char * asynchronous[] = { "YES", "NO", NULL };
1863
1864           if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1865                         NULL, NULL, open->asynchronous->value.character.string,
1866                         "OPEN", warn))
1867             goto cleanup;
1868         }
1869     }
1870
1871   /* Checks on the BLANK specifier.  */
1872   if (open->blank)
1873     {
1874       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
1875           "not allowed in Fortran 95") == FAILURE)
1876         goto cleanup;
1877
1878       if (open->blank->expr_type == EXPR_CONSTANT)
1879         {
1880           static const char *blank[] = { "ZERO", "NULL", NULL };
1881
1882           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1883                                           open->blank->value.character.string,
1884                                           "OPEN", warn))
1885             goto cleanup;
1886         }
1887     }
1888
1889   /* Checks on the DECIMAL specifier.  */
1890   if (open->decimal)
1891     {
1892       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
1893           "not allowed in Fortran 95") == FAILURE)
1894         goto cleanup;
1895
1896       if (open->decimal->expr_type == EXPR_CONSTANT)
1897         {
1898           static const char * decimal[] = { "COMMA", "POINT", NULL };
1899
1900           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1901                                           open->decimal->value.character.string,
1902                                           "OPEN", warn))
1903             goto cleanup;
1904         }
1905     }
1906
1907   /* Checks on the DELIM specifier.  */
1908   if (open->delim)
1909     {
1910       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1911           "not allowed in Fortran 95") == FAILURE)
1912         goto cleanup;
1913
1914       if (open->delim->expr_type == EXPR_CONSTANT)
1915         {
1916           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1917
1918           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1919                                           open->delim->value.character.string,
1920                                           "OPEN", warn))
1921           goto cleanup;
1922         }
1923     }
1924
1925   /* Checks on the ENCODING specifier.  */
1926   if (open->encoding)
1927     {
1928       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1929           "not allowed in Fortran 95") == FAILURE)
1930         goto cleanup;
1931     
1932       if (open->encoding->expr_type == EXPR_CONSTANT)
1933         {
1934           static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1935
1936           if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1937                                           open->encoding->value.character.string,
1938                                           "OPEN", warn))
1939           goto cleanup;
1940         }
1941     }
1942
1943   /* Checks on the FORM specifier.  */
1944   if (open->form && open->form->expr_type == EXPR_CONSTANT)
1945     {
1946       static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1947
1948       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1949                                       open->form->value.character.string,
1950                                       "OPEN", warn))
1951         goto cleanup;
1952     }
1953
1954   /* Checks on the PAD specifier.  */
1955   if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1956     {
1957       static const char *pad[] = { "YES", "NO", NULL };
1958
1959       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1960                                       open->pad->value.character.string,
1961                                       "OPEN", warn))
1962         goto cleanup;
1963     }
1964
1965   /* Checks on the POSITION specifier.  */
1966   if (open->position && open->position->expr_type == EXPR_CONSTANT)
1967     {
1968       static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
1969
1970       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
1971                                       open->position->value.character.string,
1972                                       "OPEN", warn))
1973         goto cleanup;
1974     }
1975
1976   /* Checks on the ROUND specifier.  */
1977   if (open->round)
1978     {
1979       if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
1980           "not allowed in Fortran 95") == FAILURE)
1981       goto cleanup;
1982
1983       if (open->round->expr_type == EXPR_CONSTANT)
1984         {
1985           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
1986                                           "COMPATIBLE", "PROCESSOR_DEFINED",
1987                                            NULL };
1988
1989           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
1990                                           open->round->value.character.string,
1991                                           "OPEN", warn))
1992           goto cleanup;
1993         }
1994     }
1995
1996   /* Checks on the SIGN specifier.  */
1997   if (open->sign) 
1998     {
1999       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
2000           "not allowed in Fortran 95") == FAILURE)
2001         goto cleanup;
2002
2003       if (open->sign->expr_type == EXPR_CONSTANT)
2004         {
2005           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2006                                           NULL };
2007
2008           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2009                                           open->sign->value.character.string,
2010                                           "OPEN", warn))
2011           goto cleanup;
2012         }
2013     }
2014
2015 #define warn_or_error(...) \
2016 { \
2017   if (warn) \
2018     gfc_warning (__VA_ARGS__); \
2019   else \
2020     { \
2021       gfc_error (__VA_ARGS__); \
2022       goto cleanup; \
2023     } \
2024 }
2025
2026   /* Checks on the RECL specifier.  */
2027   if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2028       && open->recl->ts.type == BT_INTEGER
2029       && mpz_sgn (open->recl->value.integer) != 1)
2030     {
2031       warn_or_error ("RECL in OPEN statement at %C must be positive");
2032     }
2033
2034   /* Checks on the STATUS specifier.  */
2035   if (open->status && open->status->expr_type == EXPR_CONSTANT)
2036     {
2037       static const char *status[] = { "OLD", "NEW", "SCRATCH",
2038         "REPLACE", "UNKNOWN", NULL };
2039
2040       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2041                                       open->status->value.character.string,
2042                                       "OPEN", warn))
2043         goto cleanup;
2044
2045       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2046          the FILE= specifier shall appear.  */
2047       if (open->file == NULL
2048           && (gfc_wide_strncasecmp (open->status->value.character.string,
2049                                     "replace", 7) == 0
2050               || gfc_wide_strncasecmp (open->status->value.character.string,
2051                                        "new", 3) == 0))
2052         {
2053           char *s = gfc_widechar_to_char (open->status->value.character.string,
2054                                           -1);
2055           warn_or_error ("The STATUS specified in OPEN statement at %C is "
2056                          "'%s' and no FILE specifier is present", s);
2057           gfc_free (s);
2058         }
2059
2060       /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2061          the FILE= specifier shall not appear.  */
2062       if (gfc_wide_strncasecmp (open->status->value.character.string,
2063                                 "scratch", 7) == 0 && open->file)
2064         {
2065           warn_or_error ("The STATUS specified in OPEN statement at %C "
2066                          "cannot have the value SCRATCH if a FILE specifier "
2067                          "is present");
2068         }
2069     }
2070
2071   /* Things that are not allowed for unformatted I/O.  */
2072   if (open->form && open->form->expr_type == EXPR_CONSTANT
2073       && (open->delim || open->decimal || open->encoding || open->round
2074           || open->sign || open->pad || open->blank)
2075       && gfc_wide_strncasecmp (open->form->value.character.string,
2076                                "unformatted", 11) == 0)
2077     {
2078       const char *spec = (open->delim ? "DELIM "
2079                                       : (open->pad ? "PAD " : open->blank
2080                                                             ? "BLANK " : ""));
2081
2082       warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2083                      "unformatted I/O", spec);
2084     }
2085
2086   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2087       && gfc_wide_strncasecmp (open->access->value.character.string,
2088                                "stream", 6) == 0)
2089     {
2090       warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2091                      "stream I/O");
2092     }
2093
2094   if (open->position
2095       && open->access && open->access->expr_type == EXPR_CONSTANT
2096       && !(gfc_wide_strncasecmp (open->access->value.character.string,
2097                                  "sequential", 10) == 0
2098            || gfc_wide_strncasecmp (open->access->value.character.string,
2099                                     "stream", 6) == 0
2100            || gfc_wide_strncasecmp (open->access->value.character.string,
2101                                     "append", 6) == 0))
2102     {
2103       warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2104                      "for stream or sequential ACCESS");
2105     }
2106
2107 #undef warn_or_error
2108
2109   new_st.op = EXEC_OPEN;
2110   new_st.ext.open = open;
2111   return MATCH_YES;
2112
2113 syntax:
2114   gfc_syntax_error (ST_OPEN);
2115
2116 cleanup:
2117   gfc_free_open (open);
2118   return MATCH_ERROR;
2119 }
2120
2121
2122 /* Free a gfc_close structure an all its expressions.  */
2123
2124 void
2125 gfc_free_close (gfc_close *close)
2126 {
2127   if (close == NULL)
2128     return;
2129
2130   gfc_free_expr (close->unit);
2131   gfc_free_expr (close->iomsg);
2132   gfc_free_expr (close->iostat);
2133   gfc_free_expr (close->status);
2134   gfc_free (close);
2135 }
2136
2137
2138 /* Match elements of a CLOSE statement.  */
2139
2140 static match
2141 match_close_element (gfc_close *close)
2142 {
2143   match m;
2144
2145   m = match_etag (&tag_unit, &close->unit);
2146   if (m != MATCH_NO)
2147     return m;
2148   m = match_etag (&tag_status, &close->status);
2149   if (m != MATCH_NO)
2150     return m;
2151   m = match_out_tag (&tag_iomsg, &close->iomsg);
2152   if (m != MATCH_NO)
2153     return m;
2154   m = match_out_tag (&tag_iostat, &close->iostat);
2155   if (m != MATCH_NO)
2156     return m;
2157   m = match_ltag (&tag_err, &close->err);
2158   if (m != MATCH_NO)
2159     return m;
2160
2161   return MATCH_NO;
2162 }
2163
2164
2165 /* Match a CLOSE statement.  */
2166
2167 match
2168 gfc_match_close (void)
2169 {
2170   gfc_close *close;
2171   match m;
2172   bool warn;
2173
2174   m = gfc_match_char ('(');
2175   if (m == MATCH_NO)
2176     return m;
2177
2178   close = XCNEW (gfc_close);
2179
2180   m = match_close_element (close);
2181
2182   if (m == MATCH_ERROR)
2183     goto cleanup;
2184   if (m == MATCH_NO)
2185     {
2186       m = gfc_match_expr (&close->unit);
2187       if (m == MATCH_NO)
2188         goto syntax;
2189       if (m == MATCH_ERROR)
2190         goto cleanup;
2191     }
2192
2193   for (;;)
2194     {
2195       if (gfc_match_char (')') == MATCH_YES)
2196         break;
2197       if (gfc_match_char (',') != MATCH_YES)
2198         goto syntax;
2199
2200       m = match_close_element (close);
2201       if (m == MATCH_ERROR)
2202         goto cleanup;
2203       if (m == MATCH_NO)
2204         goto syntax;
2205     }
2206
2207   if (gfc_match_eos () == MATCH_NO)
2208     goto syntax;
2209
2210   if (gfc_pure (NULL))
2211     {
2212       gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2213       goto cleanup;
2214     }
2215
2216   warn = (close->iostat || close->err) ? true : false;
2217
2218   /* Checks on the STATUS specifier.  */
2219   if (close->status && close->status->expr_type == EXPR_CONSTANT)
2220     {
2221       static const char *status[] = { "KEEP", "DELETE", NULL };
2222
2223       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2224                                       close->status->value.character.string,
2225                                       "CLOSE", warn))
2226         goto cleanup;
2227     }
2228
2229   new_st.op = EXEC_CLOSE;
2230   new_st.ext.close = close;
2231   return MATCH_YES;
2232
2233 syntax:
2234   gfc_syntax_error (ST_CLOSE);
2235
2236 cleanup:
2237   gfc_free_close (close);
2238   return MATCH_ERROR;
2239 }
2240
2241
2242 /* Resolve everything in a gfc_close structure.  */
2243
2244 gfc_try
2245 gfc_resolve_close (gfc_close *close)
2246 {
2247   RESOLVE_TAG (&tag_unit, close->unit);
2248   RESOLVE_TAG (&tag_iomsg, close->iomsg);
2249   RESOLVE_TAG (&tag_iostat, close->iostat);
2250   RESOLVE_TAG (&tag_status, close->status);
2251
2252   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2253     return FAILURE;
2254
2255   if (close->unit->expr_type == EXPR_CONSTANT
2256       && close->unit->ts.type == BT_INTEGER
2257       && mpz_sgn (close->unit->value.integer) < 0)
2258     {
2259       gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2260                  &close->unit->where);
2261     }
2262
2263   return SUCCESS;
2264 }
2265
2266
2267 /* Free a gfc_filepos structure.  */
2268
2269 void
2270 gfc_free_filepos (gfc_filepos *fp)
2271 {
2272   gfc_free_expr (fp->unit);
2273   gfc_free_expr (fp->iomsg);
2274   gfc_free_expr (fp->iostat);
2275   gfc_free (fp);
2276 }
2277
2278
2279 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
2280
2281 static match
2282 match_file_element (gfc_filepos *fp)
2283 {
2284   match m;
2285
2286   m = match_etag (&tag_unit, &fp->unit);
2287   if (m != MATCH_NO)
2288     return m;
2289   m = match_out_tag (&tag_iomsg, &fp->iomsg);
2290   if (m != MATCH_NO)
2291     return m;
2292   m = match_out_tag (&tag_iostat, &fp->iostat);
2293   if (m != MATCH_NO)
2294     return m;
2295   m = match_ltag (&tag_err, &fp->err);
2296   if (m != MATCH_NO)
2297     return m;
2298
2299   return MATCH_NO;
2300 }
2301
2302
2303 /* Match the second half of the file-positioning statements, REWIND,
2304    BACKSPACE, ENDFILE, or the FLUSH statement.  */
2305
2306 static match
2307 match_filepos (gfc_statement st, gfc_exec_op op)
2308 {
2309   gfc_filepos *fp;
2310   match m;
2311
2312   fp = XCNEW (gfc_filepos);
2313
2314   if (gfc_match_char ('(') == MATCH_NO)
2315     {
2316       m = gfc_match_expr (&fp->unit);
2317       if (m == MATCH_ERROR)
2318         goto cleanup;
2319       if (m == MATCH_NO)
2320         goto syntax;
2321
2322       goto done;
2323     }
2324
2325   m = match_file_element (fp);
2326   if (m == MATCH_ERROR)
2327     goto done;
2328   if (m == MATCH_NO)
2329     {
2330       m = gfc_match_expr (&fp->unit);
2331       if (m == MATCH_ERROR)
2332         goto done;
2333       if (m == MATCH_NO)
2334         goto syntax;
2335     }
2336
2337   for (;;)
2338     {
2339       if (gfc_match_char (')') == MATCH_YES)
2340         break;
2341       if (gfc_match_char (',') != MATCH_YES)
2342         goto syntax;
2343
2344       m = match_file_element (fp);
2345       if (m == MATCH_ERROR)
2346         goto cleanup;
2347       if (m == MATCH_NO)
2348         goto syntax;
2349     }
2350
2351 done:
2352   if (gfc_match_eos () != MATCH_YES)
2353     goto syntax;
2354
2355   if (gfc_pure (NULL))
2356     {
2357       gfc_error ("%s statement not allowed in PURE procedure at %C",
2358                  gfc_ascii_statement (st));
2359
2360       goto cleanup;
2361     }
2362
2363   new_st.op = op;
2364   new_st.ext.filepos = fp;
2365   return MATCH_YES;
2366
2367 syntax:
2368   gfc_syntax_error (st);
2369
2370 cleanup:
2371   gfc_free_filepos (fp);
2372   return MATCH_ERROR;
2373 }
2374
2375
2376 gfc_try
2377 gfc_resolve_filepos (gfc_filepos *fp)
2378 {
2379   RESOLVE_TAG (&tag_unit, fp->unit);
2380   RESOLVE_TAG (&tag_iostat, fp->iostat);
2381   RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2382   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2383     return FAILURE;
2384
2385   if (fp->unit->expr_type == EXPR_CONSTANT
2386       && fp->unit->ts.type == BT_INTEGER
2387       && mpz_sgn (fp->unit->value.integer) < 0)
2388     {
2389       gfc_error ("UNIT number in statement at %L must be non-negative",
2390                  &fp->unit->where);
2391     }
2392
2393   return SUCCESS;
2394 }
2395
2396
2397 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2398    and the FLUSH statement.  */
2399
2400 match
2401 gfc_match_endfile (void)
2402 {
2403   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2404 }
2405
2406 match
2407 gfc_match_backspace (void)
2408 {
2409   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2410 }
2411
2412 match
2413 gfc_match_rewind (void)
2414 {
2415   return match_filepos (ST_REWIND, EXEC_REWIND);
2416 }
2417
2418 match
2419 gfc_match_flush (void)
2420 {
2421   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2422       == FAILURE)
2423     return MATCH_ERROR;
2424
2425   return match_filepos (ST_FLUSH, EXEC_FLUSH);
2426 }
2427
2428 /******************** Data Transfer Statements *********************/
2429
2430 /* Return a default unit number.  */
2431
2432 static gfc_expr *
2433 default_unit (io_kind k)
2434 {
2435   int unit;
2436
2437   if (k == M_READ)
2438     unit = 5;
2439   else
2440     unit = 6;
2441
2442   return gfc_int_expr (unit);
2443 }
2444
2445
2446 /* Match a unit specification for a data transfer statement.  */
2447
2448 static match
2449 match_dt_unit (io_kind k, gfc_dt *dt)
2450 {
2451   gfc_expr *e;
2452
2453   if (gfc_match_char ('*') == MATCH_YES)
2454     {
2455       if (dt->io_unit != NULL)
2456         goto conflict;
2457
2458       dt->io_unit = default_unit (k);
2459       return MATCH_YES;
2460     }
2461
2462   if (gfc_match_expr (&e) == MATCH_YES)
2463     {
2464       if (dt->io_unit != NULL)
2465         {
2466           gfc_free_expr (e);
2467           goto conflict;
2468         }
2469
2470       dt->io_unit = e;
2471       return MATCH_YES;
2472     }
2473
2474   return MATCH_NO;
2475
2476 conflict:
2477   gfc_error ("Duplicate UNIT specification at %C");
2478   return MATCH_ERROR;
2479 }
2480
2481
2482 /* Match a format specification.  */
2483
2484 static match
2485 match_dt_format (gfc_dt *dt)
2486 {
2487   locus where;
2488   gfc_expr *e;
2489   gfc_st_label *label;
2490   match m;
2491
2492   where = gfc_current_locus;
2493
2494   if (gfc_match_char ('*') == MATCH_YES)
2495     {
2496       if (dt->format_expr != NULL || dt->format_label != NULL)
2497         goto conflict;
2498
2499       dt->format_label = &format_asterisk;
2500       return MATCH_YES;
2501     }
2502
2503   if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2504     {
2505       if (dt->format_expr != NULL || dt->format_label != NULL)
2506         {
2507           gfc_free_st_label (label);
2508           goto conflict;
2509         }
2510
2511       if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2512         return MATCH_ERROR;
2513
2514       dt->format_label = label;
2515       return MATCH_YES;
2516     }
2517   else if (m == MATCH_ERROR)
2518     /* The label was zero or too large.  Emit the correct diagnosis.  */
2519     return MATCH_ERROR;
2520
2521   if (gfc_match_expr (&e) == MATCH_YES)
2522     {
2523       if (dt->format_expr != NULL || dt->format_label != NULL)
2524         {
2525           gfc_free_expr (e);
2526           goto conflict;
2527         }
2528       dt->format_expr = e;
2529       return MATCH_YES;
2530     }
2531
2532   gfc_current_locus = where;    /* The only case where we have to restore */
2533
2534   return MATCH_NO;
2535
2536 conflict:
2537   gfc_error ("Duplicate format specification at %C");
2538   return MATCH_ERROR;
2539 }
2540
2541
2542 /* Traverse a namelist that is part of a READ statement to make sure
2543    that none of the variables in the namelist are INTENT(IN).  Returns
2544    nonzero if we find such a variable.  */
2545
2546 static int
2547 check_namelist (gfc_symbol *sym)
2548 {
2549   gfc_namelist *p;
2550
2551   for (p = sym->namelist; p; p = p->next)
2552     if (p->sym->attr.intent == INTENT_IN)
2553       {
2554         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2555                    p->sym->name, sym->name);
2556         return 1;
2557       }
2558
2559   return 0;
2560 }
2561
2562
2563 /* Match a single data transfer element.  */
2564
2565 static match
2566 match_dt_element (io_kind k, gfc_dt *dt)
2567 {
2568   char name[GFC_MAX_SYMBOL_LEN + 1];
2569   gfc_symbol *sym;
2570   match m;
2571
2572   if (gfc_match (" unit =") == MATCH_YES)
2573     {
2574       m = match_dt_unit (k, dt);
2575       if (m != MATCH_NO)
2576         return m;
2577     }
2578
2579   if (gfc_match (" fmt =") == MATCH_YES)
2580     {
2581       m = match_dt_format (dt);
2582       if (m != MATCH_NO)
2583         return m;
2584     }
2585
2586   if (gfc_match (" nml = %n", name) == MATCH_YES)
2587     {
2588       if (dt->namelist != NULL)
2589         {
2590           gfc_error ("Duplicate NML specification at %C");
2591           return MATCH_ERROR;
2592         }
2593
2594       if (gfc_find_symbol (name, NULL, 1, &sym))
2595         return MATCH_ERROR;
2596
2597       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2598         {
2599           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2600                      sym != NULL ? sym->name : name);
2601           return MATCH_ERROR;
2602         }
2603
2604       dt->namelist = sym;
2605       if (k == M_READ && check_namelist (sym))
2606         return MATCH_ERROR;
2607
2608       return MATCH_YES;
2609     }
2610
2611   m = match_etag (&tag_e_async, &dt->asynchronous);
2612   if (m != MATCH_NO)
2613     return m;
2614   m = match_etag (&tag_e_blank, &dt->blank);
2615   if (m != MATCH_NO)
2616     return m;
2617   m = match_etag (&tag_e_delim, &dt->delim);
2618   if (m != MATCH_NO)
2619     return m;
2620   m = match_etag (&tag_e_pad, &dt->pad);
2621   if (m != MATCH_NO)
2622     return m;
2623   m = match_etag (&tag_e_sign, &dt->sign);
2624   if (m != MATCH_NO)
2625     return m;
2626   m = match_etag (&tag_e_round, &dt->round);
2627   if (m != MATCH_NO)
2628     return m;
2629   m = match_out_tag (&tag_id, &dt->id);
2630   if (m != MATCH_NO)
2631     return m;
2632   m = match_etag (&tag_e_decimal, &dt->decimal);
2633   if (m != MATCH_NO)
2634     return m;
2635   m = match_etag (&tag_rec, &dt->rec);
2636   if (m != MATCH_NO)
2637     return m;
2638   m = match_etag (&tag_spos, &dt->pos);
2639   if (m != MATCH_NO)
2640     return m;
2641   m = match_out_tag (&tag_iomsg, &dt->iomsg);
2642   if (m != MATCH_NO)
2643     return m;
2644   m = match_out_tag (&tag_iostat, &dt->iostat);
2645   if (m != MATCH_NO)
2646     return m;
2647   m = match_ltag (&tag_err, &dt->err);
2648   if (m == MATCH_YES)
2649     dt->err_where = gfc_current_locus;
2650   if (m != MATCH_NO)
2651     return m;
2652   m = match_etag (&tag_advance, &dt->advance);
2653   if (m != MATCH_NO)
2654     return m;
2655   m = match_out_tag (&tag_size, &dt->size);
2656   if (m != MATCH_NO)
2657     return m;
2658
2659   m = match_ltag (&tag_end, &dt->end);
2660   if (m == MATCH_YES)
2661     {
2662       if (k == M_WRITE)
2663        {
2664          gfc_error ("END tag at %C not allowed in output statement");
2665          return MATCH_ERROR;
2666        }
2667       dt->end_where = gfc_current_locus;
2668     }
2669   if (m != MATCH_NO)
2670     return m;
2671
2672   m = match_ltag (&tag_eor, &dt->eor);
2673   if (m == MATCH_YES)
2674     dt->eor_where = gfc_current_locus;
2675   if (m != MATCH_NO)
2676     return m;
2677
2678   return MATCH_NO;
2679 }
2680
2681
2682 /* Free a data transfer structure and everything below it.  */
2683
2684 void
2685 gfc_free_dt (gfc_dt *dt)
2686 {
2687   if (dt == NULL)
2688     return;
2689
2690   gfc_free_expr (dt->io_unit);
2691   gfc_free_expr (dt->format_expr);
2692   gfc_free_expr (dt->rec);
2693   gfc_free_expr (dt->advance);
2694   gfc_free_expr (dt->iomsg);
2695   gfc_free_expr (dt->iostat);
2696   gfc_free_expr (dt->size);
2697   gfc_free_expr (dt->pad);
2698   gfc_free_expr (dt->delim);
2699   gfc_free_expr (dt->sign);
2700   gfc_free_expr (dt->round);
2701   gfc_free_expr (dt->blank);
2702   gfc_free_expr (dt->decimal);
2703   gfc_free_expr (dt->extra_comma);
2704   gfc_free_expr (dt->pos);
2705   gfc_free (dt);
2706 }
2707
2708
2709 /* Resolve everything in a gfc_dt structure.  */
2710
2711 gfc_try
2712 gfc_resolve_dt (gfc_dt *dt, locus *loc)
2713 {
2714   gfc_expr *e;
2715
2716   RESOLVE_TAG (&tag_format, dt->format_expr);
2717   RESOLVE_TAG (&tag_rec, dt->rec);
2718   RESOLVE_TAG (&tag_spos, dt->pos);
2719   RESOLVE_TAG (&tag_advance, dt->advance);
2720   RESOLVE_TAG (&tag_id, dt->id);
2721   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2722   RESOLVE_TAG (&tag_iostat, dt->iostat);
2723   RESOLVE_TAG (&tag_size, dt->size);
2724   RESOLVE_TAG (&tag_e_pad, dt->pad);
2725   RESOLVE_TAG (&tag_e_delim, dt->delim);
2726   RESOLVE_TAG (&tag_e_sign, dt->sign);
2727   RESOLVE_TAG (&tag_e_round, dt->round);
2728   RESOLVE_TAG (&tag_e_blank, dt->blank);
2729   RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2730   RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2731
2732   e = dt->io_unit;
2733   if (e == NULL)
2734     {
2735       gfc_error ("UNIT not specified at %L", loc);
2736       return FAILURE;
2737     }
2738
2739   if (gfc_resolve_expr (e) == SUCCESS
2740       && (e->ts.type != BT_INTEGER
2741           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2742     {
2743       /* If there is no extra comma signifying the "format" form of the IO
2744          statement, then this must be an error.  */
2745       if (!dt->extra_comma)
2746         {
2747           gfc_error ("UNIT specification at %L must be an INTEGER expression "
2748                      "or a CHARACTER variable", &e->where);
2749           return FAILURE;
2750         }
2751       else
2752         {
2753           /* At this point, we have an extra comma.  If io_unit has arrived as
2754              type character, we assume its really the "format" form of the I/O
2755              statement.  We set the io_unit to the default unit and format to
2756              the character expression.  See F95 Standard section 9.4.  */
2757           io_kind k;
2758           k = dt->extra_comma->value.iokind;
2759           if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2760             {
2761               dt->format_expr = dt->io_unit;
2762               dt->io_unit = default_unit (k);
2763
2764               /* Free this pointer now so that a warning/error is not triggered
2765                  below for the "Extension".  */
2766               gfc_free_expr (dt->extra_comma);
2767               dt->extra_comma = NULL;
2768             }
2769
2770           if (k == M_WRITE)
2771             {
2772               gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2773                          &dt->extra_comma->where);
2774               return FAILURE;
2775             }
2776         }
2777     }
2778
2779   if (e->ts.type == BT_CHARACTER)
2780     {
2781       if (gfc_has_vector_index (e))
2782         {
2783           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2784           return FAILURE;
2785         }
2786     }
2787
2788   if (e->rank && e->ts.type != BT_CHARACTER)
2789     {
2790       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2791       return FAILURE;
2792     }
2793
2794   if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2795       && mpz_sgn (e->value.integer) < 0)
2796     {
2797       gfc_error ("UNIT number in statement at %L must be non-negative", &e->where);
2798       return FAILURE;
2799     }
2800
2801   if (dt->extra_comma
2802       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2803                          "item list at %L", &dt->extra_comma->where) == FAILURE)
2804     return FAILURE;
2805
2806   if (dt->err)
2807     {
2808       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2809         return FAILURE;
2810       if (dt->err->defined == ST_LABEL_UNKNOWN)
2811         {
2812           gfc_error ("ERR tag label %d at %L not defined",
2813                       dt->err->value, &dt->err_where);
2814           return FAILURE;
2815         }
2816     }
2817
2818   if (dt->end)
2819     {
2820       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2821         return FAILURE;
2822       if (dt->end->defined == ST_LABEL_UNKNOWN)
2823         {
2824           gfc_error ("END tag label %d at %L not defined",
2825                       dt->end->value, &dt->end_where);
2826           return FAILURE;
2827         }
2828     }
2829
2830   if (dt->eor)
2831     {
2832       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2833         return FAILURE;
2834       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2835         {
2836           gfc_error ("EOR tag label %d at %L not defined",
2837                       dt->eor->value, &dt->eor_where);
2838           return FAILURE;
2839         }
2840     }
2841
2842   /* Check the format label actually exists.  */
2843   if (dt->format_label && dt->format_label != &format_asterisk
2844       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2845     {
2846       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2847                  &dt->format_label->where);
2848       return FAILURE;
2849     }
2850   return SUCCESS;
2851 }
2852
2853
2854 /* Given an io_kind, return its name.  */
2855
2856 static const char *
2857 io_kind_name (io_kind k)
2858 {
2859   const char *name;
2860
2861   switch (k)
2862     {
2863     case M_READ:
2864       name = "READ";
2865       break;
2866     case M_WRITE:
2867       name = "WRITE";
2868       break;
2869     case M_PRINT:
2870       name = "PRINT";
2871       break;
2872     case M_INQUIRE:
2873       name = "INQUIRE";
2874       break;
2875     default:
2876       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2877     }
2878
2879   return name;
2880 }
2881
2882
2883 /* Match an IO iteration statement of the form:
2884
2885    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2886
2887    which is equivalent to a single IO element.  This function is
2888    mutually recursive with match_io_element().  */
2889
2890 static match match_io_element (io_kind, gfc_code **);
2891
2892 static match
2893 match_io_iterator (io_kind k, gfc_code **result)
2894 {
2895   gfc_code *head, *tail, *new_code;
2896   gfc_iterator *iter;
2897   locus old_loc;
2898   match m;
2899   int n;
2900
2901   iter = NULL;
2902   head = NULL;
2903   old_loc = gfc_current_locus;
2904
2905   if (gfc_match_char ('(') != MATCH_YES)
2906     return MATCH_NO;
2907
2908   m = match_io_element (k, &head);
2909   tail = head;
2910
2911   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2912     {
2913       m = MATCH_NO;
2914       goto cleanup;
2915     }
2916
2917   /* Can't be anything but an IO iterator.  Build a list.  */
2918   iter = gfc_get_iterator ();
2919
2920   for (n = 1;; n++)
2921     {
2922       m = gfc_match_iterator (iter, 0);
2923       if (m == MATCH_ERROR)
2924         goto cleanup;
2925       if (m == MATCH_YES)
2926         {
2927           gfc_check_do_variable (iter->var->symtree);
2928           break;
2929         }
2930
2931       m = match_io_element (k, &new_code);
2932       if (m == MATCH_ERROR)
2933         goto cleanup;
2934       if (m == MATCH_NO)
2935         {
2936           if (n > 2)
2937             goto syntax;
2938           goto cleanup;
2939         }
2940
2941       tail = gfc_append_code (tail, new_code);
2942
2943       if (gfc_match_char (',') != MATCH_YES)
2944         {
2945           if (n > 2)
2946             goto syntax;
2947           m = MATCH_NO;
2948           goto cleanup;
2949         }
2950     }
2951
2952   if (gfc_match_char (')') != MATCH_YES)
2953     goto syntax;
2954
2955   new_code = gfc_get_code ();
2956   new_code->op = EXEC_DO;
2957   new_code->ext.iterator = iter;
2958
2959   new_code->block = gfc_get_code ();
2960   new_code->block->op = EXEC_DO;
2961   new_code->block->next = head;
2962
2963   *result = new_code;
2964   return MATCH_YES;
2965
2966 syntax:
2967   gfc_error ("Syntax error in I/O iterator at %C");
2968   m = MATCH_ERROR;
2969
2970 cleanup:
2971   gfc_free_iterator (iter, 1);
2972   gfc_free_statements (head);
2973   gfc_current_locus = old_loc;
2974   return m;
2975 }
2976
2977
2978 /* Match a single element of an IO list, which is either a single
2979    expression or an IO Iterator.  */
2980
2981 static match
2982 match_io_element (io_kind k, gfc_code **cpp)
2983 {
2984   gfc_expr *expr;
2985   gfc_code *cp;
2986   match m;
2987
2988   expr = NULL;
2989
2990   m = match_io_iterator (k, cpp);
2991   if (m == MATCH_YES)
2992     return MATCH_YES;
2993
2994   if (k == M_READ)
2995     {
2996       m = gfc_match_variable (&expr, 0);
2997       if (m == MATCH_NO)
2998         gfc_error ("Expected variable in READ statement at %C");
2999     }
3000   else
3001     {
3002       m = gfc_match_expr (&expr);
3003       if (m == MATCH_NO)
3004         gfc_error ("Expected expression in %s statement at %C",
3005                    io_kind_name (k));
3006     }
3007
3008   if (m == MATCH_YES)
3009     switch (k)
3010       {
3011       case M_READ:
3012         if (expr->symtree->n.sym->attr.intent == INTENT_IN)
3013           {
3014             gfc_error ("Variable '%s' in input list at %C cannot be "
3015                        "INTENT(IN)", expr->symtree->n.sym->name);
3016             m = MATCH_ERROR;
3017           }
3018
3019         if (gfc_pure (NULL)
3020             && gfc_impure_variable (expr->symtree->n.sym)
3021             && current_dt->io_unit
3022             && current_dt->io_unit->ts.type == BT_CHARACTER)
3023           {
3024             gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
3025                        expr->symtree->n.sym->name);
3026             m = MATCH_ERROR;
3027           }
3028
3029         if (gfc_check_do_variable (expr->symtree))
3030           m = MATCH_ERROR;
3031
3032         break;
3033
3034       case M_WRITE:
3035         if (current_dt->io_unit
3036             && current_dt->io_unit->ts.type == BT_CHARACTER
3037             && gfc_pure (NULL)
3038             && current_dt->io_unit->expr_type == EXPR_VARIABLE
3039             && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
3040           {
3041             gfc_error ("Cannot write to internal file unit '%s' at %C "
3042                        "inside a PURE procedure",
3043                        current_dt->io_unit->symtree->n.sym->name);
3044             m = MATCH_ERROR;
3045           }
3046
3047         break;
3048
3049       default:
3050         break;
3051       }
3052
3053   if (m != MATCH_YES)
3054     {
3055       gfc_free_expr (expr);
3056       return MATCH_ERROR;
3057     }
3058
3059   cp = gfc_get_code ();
3060   cp->op = EXEC_TRANSFER;
3061   cp->expr1 = expr;
3062
3063   *cpp = cp;
3064   return MATCH_YES;
3065 }
3066
3067
3068 /* Match an I/O list, building gfc_code structures as we go.  */
3069
3070 static match
3071 match_io_list (io_kind k, gfc_code **head_p)
3072 {
3073   gfc_code *head, *tail, *new_code;
3074   match m;
3075
3076   *head_p = head = tail = NULL;
3077   if (gfc_match_eos () == MATCH_YES)
3078     return MATCH_YES;
3079
3080   for (;;)
3081     {
3082       m = match_io_element (k, &new_code);
3083       if (m == MATCH_ERROR)
3084         goto cleanup;
3085       if (m == MATCH_NO)
3086         goto syntax;
3087
3088       tail = gfc_append_code (tail, new_code);
3089       if (head == NULL)
3090         head = new_code;
3091
3092       if (gfc_match_eos () == MATCH_YES)
3093         break;
3094       if (gfc_match_char (',') != MATCH_YES)
3095         goto syntax;
3096     }
3097
3098   *head_p = head;
3099   return MATCH_YES;
3100
3101 syntax:
3102   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3103
3104 cleanup:
3105   gfc_free_statements (head);
3106   return MATCH_ERROR;
3107 }
3108
3109
3110 /* Attach the data transfer end node.  */
3111
3112 static void
3113 terminate_io (gfc_code *io_code)
3114 {
3115   gfc_code *c;
3116
3117   if (io_code == NULL)
3118     io_code = new_st.block;
3119
3120   c = gfc_get_code ();
3121   c->op = EXEC_DT_END;
3122
3123   /* Point to structure that is already there */
3124   c->ext.dt = new_st.ext.dt;
3125   gfc_append_code (io_code, c);
3126 }
3127
3128
3129 /* Check the constraints for a data transfer statement.  The majority of the
3130    constraints appearing in 9.4 of the standard appear here.  Some are handled
3131    in resolve_tag and others in gfc_resolve_dt.  */
3132
3133 static match
3134 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3135                       locus *spec_end)
3136 {
3137 #define io_constraint(condition,msg,arg)\
3138 if (condition) \
3139   {\
3140     gfc_error(msg,arg);\
3141     m = MATCH_ERROR;\
3142   }
3143
3144   match m;
3145   gfc_expr *expr;
3146   gfc_symbol *sym = NULL;
3147   bool warn, unformatted;
3148
3149   warn = (dt->err || dt->iostat) ? true : false;
3150   unformatted = dt->format_expr == NULL && dt->format_label == NULL
3151                 && dt->namelist == NULL;
3152
3153   m = MATCH_YES;
3154
3155   expr = dt->io_unit;
3156   if (expr && expr->expr_type == EXPR_VARIABLE
3157       && expr->ts.type == BT_CHARACTER)
3158     {
3159       sym = expr->symtree->n.sym;
3160
3161       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3162                      "Internal file at %L must not be INTENT(IN)",
3163                      &expr->where);
3164
3165       io_constraint (gfc_has_vector_index (dt->io_unit),
3166                      "Internal file incompatible with vector subscript at %L",
3167                      &expr->where);
3168
3169       io_constraint (dt->rec != NULL,
3170                      "REC tag at %L is incompatible with internal file",
3171                      &dt->rec->where);
3172     
3173       io_constraint (dt->pos != NULL,
3174                      "POS tag at %L is incompatible with internal file",
3175                      &dt->pos->where);
3176
3177       io_constraint (unformatted,
3178                      "Unformatted I/O not allowed with internal unit at %L",
3179                      &dt->io_unit->where);
3180
3181       io_constraint (dt->asynchronous != NULL,
3182                      "ASYNCHRONOUS tag at %L not allowed with internal file",
3183                      &dt->asynchronous->where);
3184
3185       if (dt->namelist != NULL)
3186         {
3187           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
3188                               "at %L with namelist", &expr->where)
3189               == FAILURE)
3190             m = MATCH_ERROR;
3191         }
3192
3193       io_constraint (dt->advance != NULL,
3194                      "ADVANCE tag at %L is incompatible with internal file",
3195                      &dt->advance->where);
3196     }
3197
3198   if (expr && expr->ts.type != BT_CHARACTER)
3199     {
3200
3201       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3202                      "IO UNIT in %s statement at %C must be "
3203                      "an internal file in a PURE procedure",
3204                      io_kind_name (k));
3205     }
3206
3207   if (k != M_READ)
3208     {
3209       io_constraint (dt->end, "END tag not allowed with output at %L",
3210                      &dt->end_where);
3211
3212       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3213                      &dt->eor_where);
3214
3215       io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3216                      &dt->blank->where);
3217
3218       io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3219                      &dt->pad->where);
3220
3221       io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3222                      &dt->size->where);
3223     }
3224   else
3225     {
3226       io_constraint (dt->size && dt->advance == NULL,
3227                      "SIZE tag at %L requires an ADVANCE tag",
3228                      &dt->size->where);
3229
3230       io_constraint (dt->eor && dt->advance == NULL,
3231                      "EOR tag at %L requires an ADVANCE tag",
3232                      &dt->eor_where);
3233     }
3234
3235   if (dt->asynchronous) 
3236     {
3237       static const char * asynchronous[] = { "YES", "NO", NULL };
3238
3239       if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3240         {
3241           gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3242                      "expression", &dt->asynchronous->where);
3243           return MATCH_ERROR;
3244         }
3245
3246       if (!compare_to_allowed_values
3247                 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3248                  dt->asynchronous->value.character.string,
3249                  io_kind_name (k), warn))
3250         return MATCH_ERROR;
3251     }
3252
3253   if (dt->id)
3254     {
3255       bool not_yes
3256         = !dt->asynchronous
3257           || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3258           || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3259                                    "yes", 3) != 0;
3260       io_constraint (not_yes,
3261                      "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3262                      "specifier", &dt->id->where);
3263     }
3264
3265   if (dt->decimal)
3266     {
3267       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3268           "not allowed in Fortran 95") == FAILURE)
3269         return MATCH_ERROR;
3270
3271       if (dt->decimal->expr_type == EXPR_CONSTANT)
3272         {
3273           static const char * decimal[] = { "COMMA", "POINT", NULL };
3274
3275           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3276                                           dt->decimal->value.character.string,
3277                                           io_kind_name (k), warn))
3278             return MATCH_ERROR;
3279
3280           io_constraint (unformatted,
3281                          "the DECIMAL= specifier at %L must be with an "
3282                          "explicit format expression", &dt->decimal->where);
3283         }
3284     }
3285   
3286   if (dt->blank)
3287     {
3288       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3289           "not allowed in Fortran 95") == FAILURE)
3290         return MATCH_ERROR;
3291
3292       if (dt->blank->expr_type == EXPR_CONSTANT)
3293         {
3294           static const char * blank[] = { "NULL", "ZERO", NULL };
3295
3296           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3297                                           dt->blank->value.character.string,
3298                                           io_kind_name (k), warn))
3299             return MATCH_ERROR;
3300
3301           io_constraint (unformatted,
3302                          "the BLANK= specifier at %L must be with an "
3303                          "explicit format expression", &dt->blank->where);
3304         }
3305     }
3306
3307   if (dt->pad)
3308     {
3309       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3310           "not allowed in Fortran 95") == FAILURE)
3311         return MATCH_ERROR;
3312
3313       if (dt->pad->expr_type == EXPR_CONSTANT)
3314         {
3315           static const char * pad[] = { "YES", "NO", NULL };
3316
3317           if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3318                                           dt->pad->value.character.string,
3319                                           io_kind_name (k), warn))
3320             return MATCH_ERROR;
3321
3322           io_constraint (unformatted,
3323                          "the PAD= specifier at %L must be with an "
3324                          "explicit format expression", &dt->pad->where);
3325         }
3326     }
3327
3328   if (dt->round)
3329     {
3330       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3331           "not allowed in Fortran 95") == FAILURE)
3332         return MATCH_ERROR;
3333
3334       if (dt->round->expr_type == EXPR_CONSTANT)
3335         {
3336           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3337                                           "COMPATIBLE", "PROCESSOR_DEFINED",
3338                                           NULL };
3339
3340           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3341                                           dt->round->value.character.string,
3342                                           io_kind_name (k), warn))
3343             return MATCH_ERROR;
3344         }
3345     }
3346   
3347   if (dt->sign)
3348     {
3349       /* When implemented, change the following to use gfc_notify_std F2003.
3350       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3351           "not allowed in Fortran 95") == FAILURE)
3352         return MATCH_ERROR;  */
3353       if (dt->sign->expr_type == EXPR_CONSTANT)
3354         {
3355           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3356                                          NULL };
3357
3358           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3359                                       dt->sign->value.character.string,
3360                                       io_kind_name (k), warn))
3361             return MATCH_ERROR;
3362
3363           io_constraint (unformatted,
3364                          "SIGN= specifier at %L must be with an "
3365                          "explicit format expression", &dt->sign->where);
3366
3367           io_constraint (k == M_READ,
3368                          "SIGN= specifier at %L not allowed in a "
3369                          "READ statement", &dt->sign->where);
3370         }
3371     }
3372
3373   if (dt->delim)
3374     {
3375       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3376           "not allowed in Fortran 95") == FAILURE)
3377         return MATCH_ERROR;
3378
3379       if (dt->delim->expr_type == EXPR_CONSTANT)
3380         {
3381           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3382
3383           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3384                                           dt->delim->value.character.string,
3385                                           io_kind_name (k), warn))
3386             return MATCH_ERROR;
3387
3388           io_constraint (k == M_READ,
3389                          "DELIM= specifier at %L not allowed in a "
3390                          "READ statement", &dt->delim->where);
3391       
3392           io_constraint (dt->format_label != &format_asterisk
3393                          && dt->namelist == NULL,
3394                          "DELIM= specifier at %L must have FMT=*",
3395                          &dt->delim->where);
3396
3397           io_constraint (unformatted && dt->namelist == NULL,
3398                          "DELIM= specifier at %L must be with FMT=* or "
3399                          "NML= specifier ", &dt->delim->where);
3400         }
3401     }
3402   
3403   if (dt->namelist)
3404     {
3405       io_constraint (io_code && dt->namelist,
3406                      "NAMELIST cannot be followed by IO-list at %L",
3407                      &io_code->loc);
3408
3409       io_constraint (dt->format_expr,
3410                      "IO spec-list cannot contain both NAMELIST group name "
3411                      "and format specification at %L",
3412                      &dt->format_expr->where);
3413
3414       io_constraint (dt->format_label,
3415                      "IO spec-list cannot contain both NAMELIST group name "
3416                      "and format label at %L", spec_end);
3417
3418       io_constraint (dt->rec,
3419                      "NAMELIST IO is not allowed with a REC= specifier "
3420                      "at %L", &dt->rec->where);
3421
3422       io_constraint (dt->advance,
3423                      "NAMELIST IO is not allowed with a ADVANCE= specifier "
3424                      "at %L", &dt->advance->where);
3425     }
3426
3427   if (dt->rec)
3428     {
3429       io_constraint (dt->end,
3430                      "An END tag is not allowed with a "
3431                      "REC= specifier at %L", &dt->end_where);
3432
3433       io_constraint (dt->format_label == &format_asterisk,
3434                      "FMT=* is not allowed with a REC= specifier "
3435                      "at %L", spec_end);
3436
3437       io_constraint (dt->pos,
3438                      "POS= is not allowed with REC= specifier "
3439                      "at %L", &dt->pos->where);
3440     }
3441
3442   if (dt->advance)
3443     {
3444       int not_yes, not_no;
3445       expr = dt->advance;
3446
3447       io_constraint (dt->format_label == &format_asterisk,
3448                      "List directed format(*) is not allowed with a "
3449                      "ADVANCE= specifier at %L.", &expr->where);
3450
3451       io_constraint (unformatted,
3452                      "the ADVANCE= specifier at %L must appear with an "
3453                      "explicit format expression", &expr->where);
3454
3455       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3456         {
3457           const gfc_char_t *advance = expr->value.character.string;
3458           not_no = gfc_wide_strlen (advance) != 2
3459                    || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3460           not_yes = gfc_wide_strlen (advance) != 3
3461                     || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3462         }
3463       else
3464         {
3465           not_no = 0;
3466           not_yes = 0;
3467         }
3468
3469       io_constraint (not_no && not_yes,
3470                      "ADVANCE= specifier at %L must have value = "
3471                      "YES or NO.", &expr->where);
3472
3473       io_constraint (dt->size && not_no && k == M_READ,
3474                      "SIZE tag at %L requires an ADVANCE = 'NO'",
3475                      &dt->size->where);
3476
3477       io_constraint (dt->eor && not_no && k == M_READ,
3478                      "EOR tag at %L requires an ADVANCE = 'NO'",
3479                      &dt->eor_where);      
3480     }
3481
3482   expr = dt->format_expr;
3483   if (gfc_simplify_expr (expr, 0) == FAILURE
3484       || check_format_string (expr, k == M_READ) == FAILURE)
3485     return MATCH_ERROR;
3486
3487   return m;
3488 }
3489 #undef io_constraint
3490
3491
3492 /* Match a READ, WRITE or PRINT statement.  */
3493
3494 static match
3495 match_io (io_kind k)
3496 {
3497   char name[GFC_MAX_SYMBOL_LEN + 1];
3498   gfc_code *io_code;
3499   gfc_symbol *sym;
3500   int comma_flag;
3501   locus where;
3502   locus spec_end;
3503   gfc_dt *dt;
3504   match m;
3505
3506   where = gfc_current_locus;
3507   comma_flag = 0;
3508   current_dt = dt = XCNEW (gfc_dt);
3509   m = gfc_match_char ('(');
3510   if (m == MATCH_NO)
3511     {
3512       where = gfc_current_locus;
3513       if (k == M_WRITE)
3514         goto syntax;
3515       else if (k == M_PRINT)
3516         {
3517           /* Treat the non-standard case of PRINT namelist.  */
3518           if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3519               && gfc_match_name (name) == MATCH_YES)
3520             {
3521               gfc_find_symbol (name, NULL, 1, &sym);
3522               if (sym && sym->attr.flavor == FL_NAMELIST)
3523                 {
3524                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3525                                       "%C is an extension") == FAILURE)
3526                     {
3527                       m = MATCH_ERROR;
3528                       goto cleanup;
3529                     }
3530
3531                   dt->io_unit = default_unit (k);
3532                   dt->namelist = sym;
3533                   goto get_io_list;
3534                 }
3535               else
3536                 gfc_current_locus = where;
3537             }
3538         }
3539
3540       if (gfc_current_form == FORM_FREE)
3541         {
3542           char c = gfc_peek_ascii_char ();
3543           if (c != ' ' && c != '*' && c != '\'' && c != '"')
3544             {
3545               m = MATCH_NO;
3546               goto cleanup;
3547             }
3548         }
3549
3550       m = match_dt_format (dt);
3551       if (m == MATCH_ERROR)
3552         goto cleanup;
3553       if (m == MATCH_NO)
3554         goto syntax;
3555
3556       comma_flag = 1;
3557       dt->io_unit = default_unit (k);
3558       goto get_io_list;
3559     }
3560   else
3561     {
3562       /* Before issuing an error for a malformed 'print (1,*)' type of
3563          error, check for a default-char-expr of the form ('(I0)').  */
3564       if (k == M_PRINT && m == MATCH_YES)
3565         {
3566           /* Reset current locus to get the initial '(' in an expression.  */
3567           gfc_current_locus = where;
3568           dt->format_expr = NULL;
3569           m = match_dt_format (dt);
3570
3571           if (m == MATCH_ERROR)
3572             goto cleanup;
3573           if (m == MATCH_NO || dt->format_expr == NULL)
3574             goto syntax;
3575
3576           comma_flag = 1;
3577           dt->io_unit = default_unit (k);
3578           goto get_io_list;
3579         }
3580     }
3581
3582   /* Match a control list */
3583   if (match_dt_element (k, dt) == MATCH_YES)
3584     goto next;
3585   if (match_dt_unit (k, dt) != MATCH_YES)
3586     goto loop;
3587
3588   if (gfc_match_char (')') == MATCH_YES)
3589     goto get_io_list;
3590   if (gfc_match_char (',') != MATCH_YES)
3591     goto syntax;
3592
3593   m = match_dt_element (k, dt);
3594   if (m == MATCH_YES)
3595     goto next;
3596   if (m == MATCH_ERROR)
3597     goto cleanup;
3598
3599   m = match_dt_format (dt);
3600   if (m == MATCH_YES)
3601     goto next;
3602   if (m == MATCH_ERROR)
3603     goto cleanup;
3604
3605   where = gfc_current_locus;
3606
3607   m = gfc_match_name (name);
3608   if (m == MATCH_YES)
3609     {
3610       gfc_find_symbol (name, NULL, 1, &sym);
3611       if (sym && sym->attr.flavor