gcc/fortran/io.c

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