gcc/fortran/io.c

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