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 (inquire->round);
3633   gfc_free (inquire);
3634 }
3635
3636
3637 /* Match an element of an INQUIRE statement.  */
3638
3639 #define RETM   if (m != MATCH_NO) return m;
3640
3641 static match
3642 match_inquire_element (gfc_inquire *inquire)
3643 {
3644   match m;
3645
3646   m = match_etag (&tag_unit, &inquire->unit);
3647   RETM m = match_etag (&tag_file, &inquire->file);
3648   RETM m = match_ltag (&tag_err, &inquire->err);
3649   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3650   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3651   RETM m = match_vtag (&tag_exist, &inquire->exist);
3652   RETM m = match_vtag (&tag_opened, &inquire->opened);
3653   RETM m = match_vtag (&tag_named, &inquire->named);
3654   RETM m = match_vtag (&tag_name, &inquire->name);
3655   RETM m = match_out_tag (&tag_number, &inquire->number);
3656   RETM m = match_vtag (&tag_s_access, &inquire->access);
3657   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3658   RETM m = match_vtag (&tag_direct, &inquire->direct);
3659   RETM m = match_vtag (&tag_s_form, &inquire->form);
3660   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3661   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3662   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3663   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3664   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3665   RETM m = match_vtag (&tag_s_position, &inquire->position);
3666   RETM m = match_vtag (&tag_s_action, &inquire->action);
3667   RETM m = match_vtag (&tag_read, &inquire->read);
3668   RETM m = match_vtag (&tag_write, &inquire->write);
3669   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3670   RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3671   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3672   RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3673   RETM m = match_vtag (&tag_size, &inquire->size);
3674   RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3675   RETM m = match_vtag (&tag_s_round, &inquire->round);
3676   RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3677   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3678   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3679   RETM m = match_vtag (&tag_convert, &inquire->convert);
3680   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3681   RETM m = match_vtag (&tag_pending, &inquire->pending);
3682   RETM m = match_vtag (&tag_id, &inquire->id);
3683   RETM return MATCH_NO;
3684 }
3685
3686 #undef RETM
3687
3688
3689 match
3690 gfc_match_inquire (void)
3691 {
3692   gfc_inquire *inquire;
3693   gfc_code *code;
3694   match m;
3695   locus loc;
3696
3697   m = gfc_match_char ('(');
3698   if (m == MATCH_NO)
3699     return m;
3700
3701   inquire = XCNEW (gfc_inquire);
3702
3703   loc = gfc_current_locus;
3704
3705   m = match_inquire_element (inquire);
3706   if (m == MATCH_ERROR)
3707     goto cleanup;
3708   if (m == MATCH_NO)
3709     {
3710       m = gfc_match_expr (&inquire->unit);
3711       if (m == MATCH_ERROR)
3712         goto cleanup;
3713       if (m == MATCH_NO)
3714         goto syntax;
3715     }
3716
3717   /* See if we have the IOLENGTH form of the inquire statement.  */
3718   if (inquire->iolength != NULL)
3719     {
3720       if (gfc_match_char (')') != MATCH_YES)
3721         goto syntax;
3722
3723       m = match_io_list (M_INQUIRE, &code);
3724       if (m == MATCH_ERROR)
3725         goto cleanup;
3726       if (m == MATCH_NO)
3727         goto syntax;
3728
3729       new_st.op = EXEC_IOLENGTH;
3730       new_st.expr1 = inquire->iolength;
3731       new_st.ext.inquire = inquire;
3732
3733       if (gfc_pure (NULL))
3734         {
3735           gfc_free_statements (code);
3736           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3737           return MATCH_ERROR;
3738         }
3739
3740       new_st.block = gfc_get_code ();
3741       new_st.block->op = EXEC_IOLENGTH;
3742       terminate_io (code);
3743       new_st.block->next = code;
3744       return MATCH_YES;
3745     }
3746
3747   /* At this point, we have the non-IOLENGTH inquire statement.  */
3748   for (;;)
3749     {
3750       if (gfc_match_char (')') == MATCH_YES)
3751         break;
3752       if (gfc_match_char (',') != MATCH_YES)
3753         goto syntax;
3754
3755       m = match_inquire_element (inquire);
3756       if (m == MATCH_ERROR)
3757         goto cleanup;
3758       if (m == MATCH_NO)
3759         goto syntax;
3760
3761       if (inquire->iolength != NULL)
3762         {
3763           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3764           goto cleanup;
3765         }
3766     }
3767
3768   if (gfc_match_eos () != MATCH_YES)
3769     goto syntax;
3770
3771   if (inquire->unit != NULL && inquire->file != NULL)
3772     {
3773       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3774                  "UNIT specifiers", &loc);
3775       goto cleanup;
3776     }
3777
3778   if (inquire->unit == NULL && inquire->file == NULL)
3779     {
3780       gfc_error ("INQUIRE statement at %L requires either FILE or "
3781                  "UNIT specifier", &loc);
3782       goto cleanup;
3783     }
3784
3785   if (gfc_pure (NULL))
3786     {
3787       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3788       goto cleanup;
3789     }
3790
3791   if (inquire->id != NULL && inquire->pending == NULL)
3792     {
3793       gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3794                  "the ID= specifier", &loc);
3795       goto cleanup;
3796     }
3797
3798   new_st.op = EXEC_INQUIRE;
3799   new_st.ext.inquire = inquire;
3800   return MATCH_YES;
3801
3802 syntax:
3803   gfc_syntax_error (ST_INQUIRE);
3804
3805 cleanup:
3806   gfc_free_inquire (inquire);
3807   return MATCH_ERROR;
3808 }
3809
3810
3811 /* Resolve everything in a gfc_inquire structure.  */
3812
3813 gfc_try
3814 gfc_resolve_inquire (gfc_inquire *inquire)
3815 {
3816   RESOLVE_TAG (&tag_unit, inquire->unit);
3817   RESOLVE_TAG (&tag_file, inquire->file);
3818   RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
3819   RESOLVE_TAG (&tag_iostat, inquire->iostat);
3820   RESOLVE_TAG (&tag_exist, inquire->exist);
3821   RESOLVE_TAG (&tag_opened, inquire->opened);
3822   RESOLVE_TAG (&tag_number, inquire->number);
3823   RESOLVE_TAG (&tag_named, inquire->named);
3824   RESOLVE_TAG (&tag_name, inquire->name);
3825   RESOLVE_TAG (&tag_s_access, inquire->access);
3826   RESOLVE_TAG (&tag_sequential, inquire->sequential);
3827   RESOLVE_TAG (&tag_direct, inquire->direct);
3828   RESOLVE_TAG (&tag_s_form, inquire->form);
3829   RESOLVE_TAG (&tag_formatted, inquire->formatted);
3830   RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
3831   RESOLVE_TAG (&tag_s_recl, inquire->recl);
3832   RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
3833   RESOLVE_TAG (&tag_s_blank, inquire->blank);
3834   RESOLVE_TAG (&tag_s_position, inquire->position);
3835   RESOLVE_TAG (&tag_s_action, inquire->action);
3836   RESOLVE_TAG (&tag_read, inquire->read);
3837   RESOLVE_TAG (&tag_write, inquire->write);
3838   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
3839   RESOLVE_TAG (&tag_s_delim, inquire->delim);
3840   RESOLVE_TAG (&tag_s_pad, inquire->pad);
3841   RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
3842   RESOLVE_TAG (&tag_s_round, inquire->round);
3843   RESOLVE_TAG (&tag_iolength, inquire->iolength);
3844   RESOLVE_TAG (&tag_convert, inquire->convert);
3845   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
3846   RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
3847   RESOLVE_TAG (&tag_s_sign, inquire->sign);
3848   RESOLVE_TAG (&tag_s_round, inquire->round);
3849   RESOLVE_TAG (&tag_pending, inquire->pending);
3850   RESOLVE_TAG (&tag_size, inquire->size);
3851   RESOLVE_TAG (&tag_id, inquire->id);
3852
3853   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
3854     return FAILURE;
3855
3856   return SUCCESS;
3857 }
3858
3859
3860 void
3861 gfc_free_wait (gfc_wait *wait)
3862 {
3863   if (wait == NULL)
3864     return;
3865
3866   gfc_free_expr (wait->unit);
3867   gfc_free_expr (wait->iostat);
3868   gfc_free_expr (wait->iomsg);
3869   gfc_free_expr (wait->id);
3870 }
3871
3872
3873 gfc_try
3874 gfc_resolve_wait (gfc_wait *wait)
3875 {
3876   RESOLVE_TAG (&tag_unit, wait->unit);
3877   RESOLVE_TAG (&tag_iomsg, wait->iomsg);
3878   RESOLVE_TAG (&tag_iostat, wait->iostat);
3879   RESOLVE_TAG (&tag_id, wait->id);
3880
3881   if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
3882     return FAILURE;
3883
3884   if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
3885     return FAILURE;
3886
3887   return SUCCESS;
3888 }
3889
3890 /* Match an element of a WAIT statement.  */
3891
3892 #define RETM   if (m != MATCH_NO) return m;
3893
3894 static match
3895 match_wait_element (gfc_wait *wait)
3896 {
3897   match m;
3898
3899   m = match_etag (&tag_unit, &wait->unit);
3900   RETM m = match_ltag (&tag_err, &wait->err);
3901   RETM m = match_ltag (&tag_end, &wait->eor);
3902   RETM m = match_ltag (&tag_eor, &wait->end);
3903   RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
3904   RETM m = match_out_tag (&tag_iostat, &wait->iostat);
3905   RETM m = match_etag (&tag_id, &wait->id);
3906   RETM return MATCH_NO;
3907 }
3908
3909 #undef RETM
3910
3911
3912 match
3913 gfc_match_wait (void)
3914 {
3915   gfc_wait *wait;
3916   match m;
3917   locus loc;
3918
3919   m = gfc_match_char ('(');
3920   if (m == MATCH_NO)
3921     return m;
3922
3923   wait = XCNEW (gfc_wait);
3924
3925   loc = gfc_current_locus;
3926
3927   m = match_wait_element (wait);
3928   if (m == MATCH_ERROR)
3929     goto cleanup;
3930   if (m == MATCH_NO)
3931     {
3932       m = gfc_match_expr (&wait->unit);
3933       if (m == MATCH_ERROR)
3934         goto cleanup;
3935       if (m == MATCH_NO)
3936         goto syntax;
3937     }
3938
3939   for (;;)
3940     {
3941       if (gfc_match_char (')') == MATCH_YES)
3942         break;
3943       if (gfc_match_char (',') != MATCH_YES)
3944         goto syntax;
3945
3946       m = match_wait_element (wait);
3947       if (m == MATCH_ERROR)
3948         goto cleanup;
3949       if (m == MATCH_NO)
3950         goto syntax;
3951     }
3952
3953   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
3954           "not allowed in Fortran 95") == FAILURE)
3955     goto cleanup;
3956
3957   if (gfc_pure (NULL))
3958     {
3959       gfc_error ("WAIT statement not allowed in PURE procedure at %C");
3960       goto cleanup;
3961     }
3962
3963   new_st.op = EXEC_WAIT;
3964   new_st.ext.wait = wait;
3965
3966   return MATCH_YES;
3967
3968 syntax:
3969   gfc_syntax_error (ST_WAIT);
3970
3971 cleanup:
3972   gfc_free_wait (wait);
3973   return MATCH_ERROR;
3974 }