gcc/fortran/io.c

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