OSDN Git Service

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