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   if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1311     {
1312       gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1313                  tag->name);
1314       gfc_free_expr (result);
1315       return MATCH_ERROR;
1316     }
1317
1318   if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1319     gfc_current_ns->proc_name->attr.implicit_pure = 0;
1320
1321   *v = result;
1322   return MATCH_YES;
1323 }
1324
1325
1326 /* Match I/O tags that cause variables to become redefined.  */
1327
1328 static match
1329 match_out_tag (const io_tag *tag, gfc_expr **result)
1330 {
1331   match m;
1332
1333   m = match_vtag (tag, result);
1334   if (m == MATCH_YES)
1335     gfc_check_do_variable ((*result)->symtree);
1336
1337   return m;
1338 }
1339
1340
1341 /* Match a label I/O tag.  */
1342
1343 static match
1344 match_ltag (const io_tag *tag, gfc_st_label ** label)
1345 {
1346   match m;
1347   gfc_st_label *old;
1348
1349   old = *label;
1350   m = gfc_match (tag->spec);
1351   if (m != MATCH_YES)
1352     return m;
1353
1354   m = gfc_match (tag->value, label);
1355   if (m != MATCH_YES)
1356     {
1357       gfc_error ("Invalid value for %s specification at %C", tag->name);
1358       return MATCH_ERROR;
1359     }
1360
1361   if (old)
1362     {
1363       gfc_error ("Duplicate %s label specification at %C", tag->name);
1364       return MATCH_ERROR;
1365     }
1366
1367   if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1368     return MATCH_ERROR;
1369
1370   return m;
1371 }
1372
1373
1374 /* Resolution of the FORMAT tag, to be called from resolve_tag.  */
1375
1376 static gfc_try
1377 resolve_tag_format (const gfc_expr *e)
1378 {
1379   if (e->expr_type == EXPR_CONSTANT
1380       && (e->ts.type != BT_CHARACTER
1381           || e->ts.kind != gfc_default_character_kind))
1382     {
1383       gfc_error ("Constant expression in FORMAT tag at %L must be "
1384                  "of type default CHARACTER", &e->where);
1385       return FAILURE;
1386     }
1387
1388   /* If e's rank is zero and e is not an element of an array, it should be
1389      of integer or character type.  The integer variable should be
1390      ASSIGNED.  */
1391   if (e->rank == 0
1392       && (e->expr_type != EXPR_VARIABLE
1393           || e->symtree == NULL
1394           || e->symtree->n.sym->as == NULL
1395           || e->symtree->n.sym->as->rank == 0))
1396     {
1397       if ((e->ts.type != BT_CHARACTER
1398            || e->ts.kind != gfc_default_character_kind)
1399           && e->ts.type != BT_INTEGER)
1400         {
1401           gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1402                      "or of INTEGER", &e->where);
1403           return FAILURE;
1404         }
1405       else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1406         {
1407           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1408                               "variable in FORMAT tag at %L", &e->where)
1409               == FAILURE)
1410             return FAILURE;
1411           if (e->symtree->n.sym->attr.assign != 1)
1412             {
1413               gfc_error ("Variable '%s' at %L has not been assigned a "
1414                          "format label", e->symtree->n.sym->name, &e->where);
1415               return FAILURE;
1416             }
1417         }
1418       else if (e->ts.type == BT_INTEGER)
1419         {
1420           gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1421                      "variable", gfc_basic_typename (e->ts.type), &e->where);
1422           return FAILURE;
1423         }
1424
1425       return SUCCESS;
1426     }
1427
1428   /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1429      It may be assigned an Hollerith constant.  */
1430   if (e->ts.type != BT_CHARACTER)
1431     {
1432       if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1433                           "in FORMAT tag at %L", &e->where) == FAILURE)
1434         return FAILURE;
1435
1436       if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1437         {
1438           gfc_error ("Non-character assumed shape array element in FORMAT"
1439                      " tag at %L", &e->where);
1440           return FAILURE;
1441         }
1442
1443       if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1444         {
1445           gfc_error ("Non-character assumed size array element in FORMAT"
1446                      " tag at %L", &e->where);
1447           return FAILURE;
1448         }
1449
1450       if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1451         {
1452           gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1453                      &e->where);
1454           return FAILURE;
1455         }
1456     }
1457
1458   return SUCCESS;
1459 }
1460
1461
1462 /* Do expression resolution and type-checking on an expression tag.  */
1463
1464 static gfc_try
1465 resolve_tag (const io_tag *tag, gfc_expr *e)
1466 {
1467   if (e == NULL)
1468     return SUCCESS;
1469
1470   if (gfc_resolve_expr (e) == FAILURE)
1471     return FAILURE;
1472
1473   if (tag == &tag_format)
1474     return resolve_tag_format (e);
1475
1476   if (e->ts.type != tag->type)
1477     {
1478       gfc_error ("%s tag at %L must be of type %s", tag->name,
1479                  &e->where, gfc_basic_typename (tag->type));
1480       return FAILURE;
1481     }
1482
1483   if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
1484     {
1485       gfc_error ("%s tag at %L must be a character string of default kind",
1486                  tag->name, &e->where);
1487       return FAILURE;
1488     }
1489
1490   if (e->rank != 0)
1491     {
1492       gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1493       return FAILURE;
1494     }
1495
1496   if (tag == &tag_iomsg)
1497     {
1498       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1499                           &e->where) == FAILURE)
1500         return FAILURE;
1501     }
1502
1503   if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1504       && e->ts.kind != gfc_default_integer_kind)
1505     {
1506       if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1507                           "INTEGER in %s tag at %L", tag->name, &e->where)
1508           == FAILURE)
1509         return FAILURE;
1510     }
1511
1512   if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind)
1513     {
1514       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Nondefault LOGICAL "
1515                           "in %s tag at %L", tag->name, &e->where)
1516           == FAILURE)
1517         return FAILURE;
1518     }
1519
1520   if (tag == &tag_newunit)
1521     {
1522       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: NEWUNIT specifier"
1523                           " at %L", &e->where) == FAILURE)
1524         return FAILURE;
1525     }
1526
1527   /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts.  */
1528   if (tag == &tag_newunit || tag == &tag_iostat
1529       || tag == &tag_size || tag == &tag_iomsg)
1530     {
1531       char context[64];
1532
1533       sprintf (context, _("%s tag"), tag->name);
1534       if (gfc_check_vardef_context (e, false, false, context) == FAILURE)
1535         return FAILURE;
1536     }
1537
1538   if (tag == &tag_convert)
1539     {
1540       if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1541                           &e->where) == FAILURE)
1542         return FAILURE;
1543     }
1544
1545   return SUCCESS;
1546 }
1547
1548
1549 /* Match a single tag of an OPEN statement.  */
1550
1551 static match
1552 match_open_element (gfc_open *open)
1553 {
1554   match m;
1555
1556   m = match_etag (&tag_e_async, &open->asynchronous);
1557   if (m != MATCH_NO)
1558     return m;
1559   m = match_etag (&tag_unit, &open->unit);
1560   if (m != MATCH_NO)
1561     return m;
1562   m = match_out_tag (&tag_iomsg, &open->iomsg);
1563   if (m != MATCH_NO)
1564     return m;
1565   m = match_out_tag (&tag_iostat, &open->iostat);
1566   if (m != MATCH_NO)
1567     return m;
1568   m = match_etag (&tag_file, &open->file);
1569   if (m != MATCH_NO)
1570     return m;
1571   m = match_etag (&tag_status, &open->status);
1572   if (m != MATCH_NO)
1573     return m;
1574   m = match_etag (&tag_e_access, &open->access);
1575   if (m != MATCH_NO)
1576     return m;
1577   m = match_etag (&tag_e_form, &open->form);
1578   if (m != MATCH_NO)
1579     return m;
1580   m = match_etag (&tag_e_recl, &open->recl);
1581   if (m != MATCH_NO)
1582     return m;
1583   m = match_etag (&tag_e_blank, &open->blank);
1584   if (m != MATCH_NO)
1585     return m;
1586   m = match_etag (&tag_e_position, &open->position);
1587   if (m != MATCH_NO)
1588     return m;
1589   m = match_etag (&tag_e_action, &open->action);
1590   if (m != MATCH_NO)
1591     return m;
1592   m = match_etag (&tag_e_delim, &open->delim);
1593   if (m != MATCH_NO)
1594     return m;
1595   m = match_etag (&tag_e_pad, &open->pad);
1596   if (m != MATCH_NO)
1597     return m;
1598   m = match_etag (&tag_e_decimal, &open->decimal);
1599   if (m != MATCH_NO)
1600     return m;
1601   m = match_etag (&tag_e_encoding, &open->encoding);
1602   if (m != MATCH_NO)
1603     return m;
1604   m = match_etag (&tag_e_round, &open->round);
1605   if (m != MATCH_NO)
1606     return m;
1607   m = match_etag (&tag_e_sign, &open->sign);
1608   if (m != MATCH_NO)
1609     return m;
1610   m = match_ltag (&tag_err, &open->err);
1611   if (m != MATCH_NO)
1612     return m;
1613   m = match_etag (&tag_convert, &open->convert);
1614   if (m != MATCH_NO)
1615     return m;
1616   m = match_out_tag (&tag_newunit, &open->newunit);
1617   if (m != MATCH_NO)
1618     return m;
1619
1620   return MATCH_NO;
1621 }
1622
1623
1624 /* Free the gfc_open structure and all the expressions it contains.  */
1625
1626 void
1627 gfc_free_open (gfc_open *open)
1628 {
1629   if (open == NULL)
1630     return;
1631
1632   gfc_free_expr (open->unit);
1633   gfc_free_expr (open->iomsg);
1634   gfc_free_expr (open->iostat);
1635   gfc_free_expr (open->file);
1636   gfc_free_expr (open->status);
1637   gfc_free_expr (open->access);
1638   gfc_free_expr (open->form);
1639   gfc_free_expr (open->recl);
1640   gfc_free_expr (open->blank);
1641   gfc_free_expr (open->position);
1642   gfc_free_expr (open->action);
1643   gfc_free_expr (open->delim);
1644   gfc_free_expr (open->pad);
1645   gfc_free_expr (open->decimal);
1646   gfc_free_expr (open->encoding);
1647   gfc_free_expr (open->round);
1648   gfc_free_expr (open->sign);
1649   gfc_free_expr (open->convert);
1650   gfc_free_expr (open->asynchronous);
1651   gfc_free_expr (open->newunit);
1652   free (open);
1653 }
1654
1655
1656 /* Resolve everything in a gfc_open structure.  */
1657
1658 gfc_try
1659 gfc_resolve_open (gfc_open *open)
1660 {
1661
1662   RESOLVE_TAG (&tag_unit, open->unit);
1663   RESOLVE_TAG (&tag_iomsg, open->iomsg);
1664   RESOLVE_TAG (&tag_iostat, open->iostat);
1665   RESOLVE_TAG (&tag_file, open->file);
1666   RESOLVE_TAG (&tag_status, open->status);
1667   RESOLVE_TAG (&tag_e_access, open->access);
1668   RESOLVE_TAG (&tag_e_form, open->form);
1669   RESOLVE_TAG (&tag_e_recl, open->recl);
1670   RESOLVE_TAG (&tag_e_blank, open->blank);
1671   RESOLVE_TAG (&tag_e_position, open->position);
1672   RESOLVE_TAG (&tag_e_action, open->action);
1673   RESOLVE_TAG (&tag_e_delim, open->delim);
1674   RESOLVE_TAG (&tag_e_pad, open->pad);
1675   RESOLVE_TAG (&tag_e_decimal, open->decimal);
1676   RESOLVE_TAG (&tag_e_encoding, open->encoding);
1677   RESOLVE_TAG (&tag_e_async, open->asynchronous);
1678   RESOLVE_TAG (&tag_e_round, open->round);
1679   RESOLVE_TAG (&tag_e_sign, open->sign);
1680   RESOLVE_TAG (&tag_convert, open->convert);
1681   RESOLVE_TAG (&tag_newunit, open->newunit);
1682
1683   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1684     return FAILURE;
1685
1686   return SUCCESS;
1687 }
1688
1689
1690 /* Check if a given value for a SPECIFIER is either in the list of values
1691    allowed in F95 or F2003, issuing an error message and returning a zero
1692    value if it is not allowed.  */
1693
1694 static int
1695 compare_to_allowed_values (const char *specifier, const char *allowed[],
1696                            const char *allowed_f2003[],
1697                            const char *allowed_gnu[], gfc_char_t *value,
1698                            const char *statement, bool warn)
1699 {
1700   int i;
1701   unsigned int len;
1702
1703   len = gfc_wide_strlen (value);
1704   if (len > 0)
1705   {
1706     for (len--; len > 0; len--)
1707       if (value[len] != ' ')
1708         break;
1709     len++;
1710   }
1711
1712   for (i = 0; allowed[i]; i++)
1713     if (len == strlen (allowed[i])
1714         && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1715       return 1;
1716
1717   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1718     if (len == strlen (allowed_f2003[i])
1719         && gfc_wide_strncasecmp (value, allowed_f2003[i],
1720                                  strlen (allowed_f2003[i])) == 0)
1721       {
1722         notification n = gfc_notification_std (GFC_STD_F2003);
1723
1724         if (n == WARNING || (warn && n == ERROR))
1725           {
1726             gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1727                          "has value '%s'", specifier, statement,
1728                          allowed_f2003[i]);
1729             return 1;
1730           }
1731         else
1732           if (n == ERROR)
1733             {
1734               gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1735                               "%s statement at %C has value '%s'", specifier,
1736                               statement, allowed_f2003[i]);
1737               return 0;
1738             }
1739
1740         /* n == SILENT */
1741         return 1;
1742       }
1743
1744   for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1745     if (len == strlen (allowed_gnu[i])
1746         && gfc_wide_strncasecmp (value, allowed_gnu[i],
1747                                  strlen (allowed_gnu[i])) == 0)
1748       {
1749         notification n = gfc_notification_std (GFC_STD_GNU);
1750
1751         if (n == WARNING || (warn && n == ERROR))
1752           {
1753             gfc_warning ("Extension: %s specifier in %s statement at %C "
1754                          "has value '%s'", specifier, statement,
1755                          allowed_gnu[i]);
1756             return 1;
1757           }
1758         else
1759           if (n == ERROR)
1760             {
1761               gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1762                               "%s statement at %C has value '%s'", specifier,
1763                               statement, allowed_gnu[i]);
1764               return 0;
1765             }
1766
1767         /* n == SILENT */
1768         return 1;
1769       }
1770
1771   if (warn)
1772     {
1773       char *s = gfc_widechar_to_char (value, -1);
1774       gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1775                    specifier, statement, s);
1776       free (s);
1777       return 1;
1778     }
1779   else
1780     {
1781       char *s = gfc_widechar_to_char (value, -1);
1782       gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1783                  specifier, statement, s);
1784       free (s);
1785       return 0;
1786     }
1787 }
1788
1789
1790 /* Match an OPEN statement.  */
1791
1792 match
1793 gfc_match_open (void)
1794 {
1795   gfc_open *open;
1796   match m;
1797   bool warn;
1798
1799   m = gfc_match_char ('(');
1800   if (m == MATCH_NO)
1801     return m;
1802
1803   open = XCNEW (gfc_open);
1804
1805   m = match_open_element (open);
1806
1807   if (m == MATCH_ERROR)
1808     goto cleanup;
1809   if (m == MATCH_NO)
1810     {
1811       m = gfc_match_expr (&open->unit);
1812       if (m == MATCH_ERROR)
1813         goto cleanup;
1814     }
1815
1816   for (;;)
1817     {
1818       if (gfc_match_char (')') == MATCH_YES)
1819         break;
1820       if (gfc_match_char (',') != MATCH_YES)
1821         goto syntax;
1822
1823       m = match_open_element (open);
1824       if (m == MATCH_ERROR)
1825         goto cleanup;
1826       if (m == MATCH_NO)
1827         goto syntax;
1828     }
1829
1830   if (gfc_match_eos () == MATCH_NO)
1831     goto syntax;
1832
1833   if (gfc_pure (NULL))
1834     {
1835       gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1836       goto cleanup;
1837     }
1838
1839   if (gfc_implicit_pure (NULL))
1840     gfc_current_ns->proc_name->attr.implicit_pure = 0;
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   if (gfc_implicit_pure (NULL))
2253     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2254
2255   warn = (close->iostat || close->err) ? true : false;
2256
2257   /* Checks on the STATUS specifier.  */
2258   if (close->status && close->status->expr_type == EXPR_CONSTANT)
2259     {
2260       static const char *status[] = { "KEEP", "DELETE", NULL };
2261
2262       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2263                                       close->status->value.character.string,
2264                                       "CLOSE", warn))
2265         goto cleanup;
2266     }
2267
2268   new_st.op = EXEC_CLOSE;
2269   new_st.ext.close = close;
2270   return MATCH_YES;
2271
2272 syntax:
2273   gfc_syntax_error (ST_CLOSE);
2274
2275 cleanup:
2276   gfc_free_close (close);
2277   return MATCH_ERROR;
2278 }
2279
2280
2281 /* Resolve everything in a gfc_close structure.  */
2282
2283 gfc_try
2284 gfc_resolve_close (gfc_close *close)
2285 {
2286   RESOLVE_TAG (&tag_unit, close->unit);
2287   RESOLVE_TAG (&tag_iomsg, close->iomsg);
2288   RESOLVE_TAG (&tag_iostat, close->iostat);
2289   RESOLVE_TAG (&tag_status, close->status);
2290
2291   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2292     return FAILURE;
2293
2294   if (close->unit == NULL)
2295     {
2296       /* Find a locus from one of the arguments to close, when UNIT is
2297          not specified.  */
2298       locus loc = gfc_current_locus;
2299       if (close->status)
2300         loc = close->status->where;
2301       else if (close->iostat)
2302         loc = close->iostat->where;
2303       else if (close->iomsg)
2304         loc = close->iomsg->where;
2305       else if (close->err)
2306         loc = close->err->where;
2307
2308       gfc_error ("CLOSE statement at %L requires a UNIT number", &loc);
2309       return FAILURE;
2310     }
2311
2312   if (close->unit->expr_type == EXPR_CONSTANT
2313       && close->unit->ts.type == BT_INTEGER
2314       && mpz_sgn (close->unit->value.integer) < 0)
2315     {
2316       gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2317                  &close->unit->where);
2318     }
2319
2320   return SUCCESS;
2321 }
2322
2323
2324 /* Free a gfc_filepos structure.  */
2325
2326 void
2327 gfc_free_filepos (gfc_filepos *fp)
2328 {
2329   gfc_free_expr (fp->unit);
2330   gfc_free_expr (fp->iomsg);
2331   gfc_free_expr (fp->iostat);
2332   free (fp);
2333 }
2334
2335
2336 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
2337
2338 static match
2339 match_file_element (gfc_filepos *fp)
2340 {
2341   match m;
2342
2343   m = match_etag (&tag_unit, &fp->unit);
2344   if (m != MATCH_NO)
2345     return m;
2346   m = match_out_tag (&tag_iomsg, &fp->iomsg);
2347   if (m != MATCH_NO)
2348     return m;
2349   m = match_out_tag (&tag_iostat, &fp->iostat);
2350   if (m != MATCH_NO)
2351     return m;
2352   m = match_ltag (&tag_err, &fp->err);
2353   if (m != MATCH_NO)
2354     return m;
2355
2356   return MATCH_NO;
2357 }
2358
2359
2360 /* Match the second half of the file-positioning statements, REWIND,
2361    BACKSPACE, ENDFILE, or the FLUSH statement.  */
2362
2363 static match
2364 match_filepos (gfc_statement st, gfc_exec_op op)
2365 {
2366   gfc_filepos *fp;
2367   match m;
2368
2369   fp = XCNEW (gfc_filepos);
2370
2371   if (gfc_match_char ('(') == MATCH_NO)
2372     {
2373       m = gfc_match_expr (&fp->unit);
2374       if (m == MATCH_ERROR)
2375         goto cleanup;
2376       if (m == MATCH_NO)
2377         goto syntax;
2378
2379       goto done;
2380     }
2381
2382   m = match_file_element (fp);
2383   if (m == MATCH_ERROR)
2384     goto done;
2385   if (m == MATCH_NO)
2386     {
2387       m = gfc_match_expr (&fp->unit);
2388       if (m == MATCH_ERROR)
2389         goto done;
2390       if (m == MATCH_NO)
2391         goto syntax;
2392     }
2393
2394   for (;;)
2395     {
2396       if (gfc_match_char (')') == MATCH_YES)
2397         break;
2398       if (gfc_match_char (',') != MATCH_YES)
2399         goto syntax;
2400
2401       m = match_file_element (fp);
2402       if (m == MATCH_ERROR)
2403         goto cleanup;
2404       if (m == MATCH_NO)
2405         goto syntax;
2406     }
2407
2408 done:
2409   if (gfc_match_eos () != MATCH_YES)
2410     goto syntax;
2411
2412   if (gfc_pure (NULL))
2413     {
2414       gfc_error ("%s statement not allowed in PURE procedure at %C",
2415                  gfc_ascii_statement (st));
2416
2417       goto cleanup;
2418     }
2419
2420   if (gfc_implicit_pure (NULL))
2421     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2422
2423   new_st.op = op;
2424   new_st.ext.filepos = fp;
2425   return MATCH_YES;
2426
2427 syntax:
2428   gfc_syntax_error (st);
2429
2430 cleanup:
2431   gfc_free_filepos (fp);
2432   return MATCH_ERROR;
2433 }
2434
2435
2436 gfc_try
2437 gfc_resolve_filepos (gfc_filepos *fp)
2438 {
2439   RESOLVE_TAG (&tag_unit, fp->unit);
2440   RESOLVE_TAG (&tag_iostat, fp->iostat);
2441   RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2442   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2443     return FAILURE;
2444
2445   if (fp->unit->expr_type == EXPR_CONSTANT
2446       && fp->unit->ts.type == BT_INTEGER
2447       && mpz_sgn (fp->unit->value.integer) < 0)
2448     {
2449       gfc_error ("UNIT number in statement at %L must be non-negative",
2450                  &fp->unit->where);
2451     }
2452
2453   return SUCCESS;
2454 }
2455
2456
2457 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2458    and the FLUSH statement.  */
2459
2460 match
2461 gfc_match_endfile (void)
2462 {
2463   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2464 }
2465
2466 match
2467 gfc_match_backspace (void)
2468 {
2469   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2470 }
2471
2472 match
2473 gfc_match_rewind (void)
2474 {
2475   return match_filepos (ST_REWIND, EXEC_REWIND);
2476 }
2477
2478 match
2479 gfc_match_flush (void)
2480 {
2481   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2482       == FAILURE)
2483     return MATCH_ERROR;
2484
2485   return match_filepos (ST_FLUSH, EXEC_FLUSH);
2486 }
2487
2488 /******************** Data Transfer Statements *********************/
2489
2490 /* Return a default unit number.  */
2491
2492 static gfc_expr *
2493 default_unit (io_kind k)
2494 {
2495   int unit;
2496
2497   if (k == M_READ)
2498     unit = 5;
2499   else
2500     unit = 6;
2501
2502   return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2503 }
2504
2505
2506 /* Match a unit specification for a data transfer statement.  */
2507
2508 static match
2509 match_dt_unit (io_kind k, gfc_dt *dt)
2510 {
2511   gfc_expr *e;
2512
2513   if (gfc_match_char ('*') == MATCH_YES)
2514     {
2515       if (dt->io_unit != NULL)
2516         goto conflict;
2517
2518       dt->io_unit = default_unit (k);
2519       return MATCH_YES;
2520     }
2521
2522   if (gfc_match_expr (&e) == MATCH_YES)
2523     {
2524       if (dt->io_unit != NULL)
2525         {
2526           gfc_free_expr (e);
2527           goto conflict;
2528         }
2529
2530       dt->io_unit = e;
2531       return MATCH_YES;
2532     }
2533
2534   return MATCH_NO;
2535
2536 conflict:
2537   gfc_error ("Duplicate UNIT specification at %C");
2538   return MATCH_ERROR;
2539 }
2540
2541
2542 /* Match a format specification.  */
2543
2544 static match
2545 match_dt_format (gfc_dt *dt)
2546 {
2547   locus where;
2548   gfc_expr *e;
2549   gfc_st_label *label;
2550   match m;
2551
2552   where = gfc_current_locus;
2553
2554   if (gfc_match_char ('*') == MATCH_YES)
2555     {
2556       if (dt->format_expr != NULL || dt->format_label != NULL)
2557         goto conflict;
2558
2559       dt->format_label = &format_asterisk;
2560       return MATCH_YES;
2561     }
2562
2563   if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2564     {
2565       char c;
2566
2567       /* Need to check if the format label is actually either an operand
2568          to a user-defined operator or is a kind type parameter.  That is,
2569          print 2.ip.8      ! .ip. is a user-defined operator return CHARACTER.
2570          print 1_'(I0)', i ! 1_'(I0)' is a default character string.  */
2571
2572       gfc_gobble_whitespace ();
2573       c = gfc_peek_ascii_char ();
2574       if (c == '.' || c == '_')
2575         gfc_current_locus = where;
2576       else
2577         {
2578           if (dt->format_expr != NULL || dt->format_label != NULL)
2579             {
2580               gfc_free_st_label (label);
2581               goto conflict;
2582             }
2583
2584           if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2585             return MATCH_ERROR;
2586
2587           dt->format_label = label;
2588           return MATCH_YES;
2589         }
2590     }
2591   else if (m == MATCH_ERROR)
2592     /* The label was zero or too large.  Emit the correct diagnosis.  */
2593     return MATCH_ERROR;
2594
2595   if (gfc_match_expr (&e) == MATCH_YES)
2596     {
2597       if (dt->format_expr != NULL || dt->format_label != NULL)
2598         {
2599           gfc_free_expr (e);
2600           goto conflict;
2601         }
2602       dt->format_expr = e;
2603       return MATCH_YES;
2604     }
2605
2606   gfc_current_locus = where;    /* The only case where we have to restore */
2607
2608   return MATCH_NO;
2609
2610 conflict:
2611   gfc_error ("Duplicate format specification at %C");
2612   return MATCH_ERROR;
2613 }
2614
2615
2616 /* Traverse a namelist that is part of a READ statement to make sure
2617    that none of the variables in the namelist are INTENT(IN).  Returns
2618    nonzero if we find such a variable.  */
2619
2620 static int
2621 check_namelist (gfc_symbol *sym)
2622 {
2623   gfc_namelist *p;
2624
2625   for (p = sym->namelist; p; p = p->next)
2626     if (p->sym->attr.intent == INTENT_IN)
2627       {
2628         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2629                    p->sym->name, sym->name);
2630         return 1;
2631       }
2632
2633   return 0;
2634 }
2635
2636
2637 /* Match a single data transfer element.  */
2638
2639 static match
2640 match_dt_element (io_kind k, gfc_dt *dt)
2641 {
2642   char name[GFC_MAX_SYMBOL_LEN + 1];
2643   gfc_symbol *sym;
2644   match m;
2645
2646   if (gfc_match (" unit =") == MATCH_YES)
2647     {
2648       m = match_dt_unit (k, dt);
2649       if (m != MATCH_NO)
2650         return m;
2651     }
2652
2653   if (gfc_match (" fmt =") == MATCH_YES)
2654     {
2655       m = match_dt_format (dt);
2656       if (m != MATCH_NO)
2657         return m;
2658     }
2659
2660   if (gfc_match (" nml = %n", name) == MATCH_YES)
2661     {
2662       if (dt->namelist != NULL)
2663         {
2664           gfc_error ("Duplicate NML specification at %C");
2665           return MATCH_ERROR;
2666         }
2667
2668       if (gfc_find_symbol (name, NULL, 1, &sym))
2669         return MATCH_ERROR;
2670
2671       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2672         {
2673           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2674                      sym != NULL ? sym->name : name);
2675           return MATCH_ERROR;
2676         }
2677
2678       dt->namelist = sym;
2679       if (k == M_READ && check_namelist (sym))
2680         return MATCH_ERROR;
2681
2682       return MATCH_YES;
2683     }
2684
2685   m = match_etag (&tag_e_async, &dt->asynchronous);
2686   if (m != MATCH_NO)
2687     return m;
2688   m = match_etag (&tag_e_blank, &dt->blank);
2689   if (m != MATCH_NO)
2690     return m;
2691   m = match_etag (&tag_e_delim, &dt->delim);
2692   if (m != MATCH_NO)
2693     return m;
2694   m = match_etag (&tag_e_pad, &dt->pad);
2695   if (m != MATCH_NO)
2696     return m;
2697   m = match_etag (&tag_e_sign, &dt->sign);
2698   if (m != MATCH_NO)
2699     return m;
2700   m = match_etag (&tag_e_round, &dt->round);
2701   if (m != MATCH_NO)
2702     return m;
2703   m = match_out_tag (&tag_id, &dt->id);
2704   if (m != MATCH_NO)
2705     return m;
2706   m = match_etag (&tag_e_decimal, &dt->decimal);
2707   if (m != MATCH_NO)
2708     return m;
2709   m = match_etag (&tag_rec, &dt->rec);
2710   if (m != MATCH_NO)
2711     return m;
2712   m = match_etag (&tag_spos, &dt->pos);
2713   if (m != MATCH_NO)
2714     return m;
2715   m = match_out_tag (&tag_iomsg, &dt->iomsg);
2716   if (m != MATCH_NO)
2717     return m;
2718   m = match_out_tag (&tag_iostat, &dt->iostat);
2719   if (m != MATCH_NO)
2720     return m;
2721   m = match_ltag (&tag_err, &dt->err);
2722   if (m == MATCH_YES)
2723     dt->err_where = gfc_current_locus;
2724   if (m != MATCH_NO)
2725     return m;
2726   m = match_etag (&tag_advance, &dt->advance);
2727   if (m != MATCH_NO)
2728     return m;
2729   m = match_out_tag (&tag_size, &dt->size);
2730   if (m != MATCH_NO)
2731     return m;
2732
2733   m = match_ltag (&tag_end, &dt->end);
2734   if (m == MATCH_YES)
2735     {
2736       if (k == M_WRITE)
2737        {
2738          gfc_error ("END tag at %C not allowed in output statement");
2739          return MATCH_ERROR;
2740        }
2741       dt->end_where = gfc_current_locus;
2742     }
2743   if (m != MATCH_NO)
2744     return m;
2745
2746   m = match_ltag (&tag_eor, &dt->eor);
2747   if (m == MATCH_YES)
2748     dt->eor_where = gfc_current_locus;
2749   if (m != MATCH_NO)
2750     return m;
2751
2752   return MATCH_NO;
2753 }
2754
2755
2756 /* Free a data transfer structure and everything below it.  */
2757
2758 void
2759 gfc_free_dt (gfc_dt *dt)
2760 {
2761   if (dt == NULL)
2762     return;
2763
2764   gfc_free_expr (dt->io_unit);
2765   gfc_free_expr (dt->format_expr);
2766   gfc_free_expr (dt->rec);
2767   gfc_free_expr (dt->advance);
2768   gfc_free_expr (dt->iomsg);
2769   gfc_free_expr (dt->iostat);
2770   gfc_free_expr (dt->size);
2771   gfc_free_expr (dt->pad);
2772   gfc_free_expr (dt->delim);
2773   gfc_free_expr (dt->sign);
2774   gfc_free_expr (dt->round);
2775   gfc_free_expr (dt->blank);
2776   gfc_free_expr (dt->decimal);
2777   gfc_free_expr (dt->pos);
2778   gfc_free_expr (dt->dt_io_kind);
2779   /* dt->extra_comma is a link to dt_io_kind if it is set.  */
2780   free (dt);
2781 }
2782
2783
2784 /* Resolve everything in a gfc_dt structure.  */
2785
2786 gfc_try
2787 gfc_resolve_dt (gfc_dt *dt, locus *loc)
2788 {
2789   gfc_expr *e;
2790   io_kind k;
2791
2792   /* This is set in any case.  */
2793   gcc_assert (dt->dt_io_kind);
2794   k = dt->dt_io_kind->value.iokind;
2795
2796   RESOLVE_TAG (&tag_format, dt->format_expr);
2797   RESOLVE_TAG (&tag_rec, dt->rec);
2798   RESOLVE_TAG (&tag_spos, dt->pos);
2799   RESOLVE_TAG (&tag_advance, dt->advance);
2800   RESOLVE_TAG (&tag_id, dt->id);
2801   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2802   RESOLVE_TAG (&tag_iostat, dt->iostat);
2803   RESOLVE_TAG (&tag_size, dt->size);
2804   RESOLVE_TAG (&tag_e_pad, dt->pad);
2805   RESOLVE_TAG (&tag_e_delim, dt->delim);
2806   RESOLVE_TAG (&tag_e_sign, dt->sign);
2807   RESOLVE_TAG (&tag_e_round, dt->round);
2808   RESOLVE_TAG (&tag_e_blank, dt->blank);
2809   RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2810   RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2811
2812   e = dt->io_unit;
2813   if (e == NULL)
2814     {
2815       gfc_error ("UNIT not specified at %L", loc);
2816       return FAILURE;
2817     }
2818
2819   if (gfc_resolve_expr (e) == SUCCESS
2820       && (e->ts.type != BT_INTEGER
2821           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2822     {
2823       /* If there is no extra comma signifying the "format" form of the IO
2824          statement, then this must be an error.  */
2825       if (!dt->extra_comma)
2826         {
2827           gfc_error ("UNIT specification at %L must be an INTEGER expression "
2828                      "or a CHARACTER variable", &e->where);
2829           return FAILURE;
2830         }
2831       else
2832         {
2833           /* At this point, we have an extra comma.  If io_unit has arrived as
2834              type character, we assume its really the "format" form of the I/O
2835              statement.  We set the io_unit to the default unit and format to
2836              the character expression.  See F95 Standard section 9.4.  */
2837           if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2838             {
2839               dt->format_expr = dt->io_unit;
2840               dt->io_unit = default_unit (k);
2841
2842               /* Nullify this pointer now so that a warning/error is not
2843                  triggered below for the "Extension".  */
2844               dt->extra_comma = NULL;
2845             }
2846
2847           if (k == M_WRITE)
2848             {
2849               gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2850                          &dt->extra_comma->where);
2851               return FAILURE;
2852             }
2853         }
2854     }
2855
2856   if (e->ts.type == BT_CHARACTER)
2857     {
2858       if (gfc_has_vector_index (e))
2859         {
2860           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2861           return FAILURE;
2862         }
2863
2864       /* If we are writing, make sure the internal unit can be changed.  */
2865       gcc_assert (k != M_PRINT);
2866       if (k == M_WRITE
2867           && gfc_check_vardef_context (e, false, false,
2868                                        _("internal unit in WRITE")) == FAILURE)
2869         return FAILURE;
2870     }
2871
2872   if (e->rank && e->ts.type != BT_CHARACTER)
2873     {
2874       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2875       return FAILURE;
2876     }
2877
2878   if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2879       && mpz_sgn (e->value.integer) < 0)
2880     {
2881       gfc_error ("UNIT number in statement at %L must be non-negative",
2882                  &e->where);
2883       return FAILURE;
2884     }
2885
2886   /* If we are reading and have a namelist, check that all namelist symbols
2887      can appear in a variable definition context.  */
2888   if (k == M_READ && dt->namelist)
2889     {
2890       gfc_namelist* n;
2891       for (n = dt->namelist->namelist; n; n = n->next)
2892         {
2893           gfc_expr* e;
2894           gfc_try t;
2895
2896           e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
2897           t = gfc_check_vardef_context (e, false, false, NULL);
2898           gfc_free_expr (e);
2899
2900           if (t == FAILURE)
2901             {
2902               gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2903                          " the symbol '%s' which may not appear in a"
2904                          " variable definition context",
2905                          dt->namelist->name, loc, n->sym->name);
2906               return FAILURE;
2907             }
2908         }
2909     }
2910
2911   if (dt->extra_comma
2912       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2913                          "item list at %L", &dt->extra_comma->where) == FAILURE)
2914     return FAILURE;
2915
2916   if (dt->err)
2917     {
2918       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2919         return FAILURE;
2920       if (dt->err->defined == ST_LABEL_UNKNOWN)
2921         {
2922           gfc_error ("ERR tag label %d at %L not defined",
2923                       dt->err->value, &dt->err_where);
2924           return FAILURE;
2925         }
2926     }
2927
2928   if (dt->end)
2929     {
2930       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2931         return FAILURE;
2932       if (dt->end->defined == ST_LABEL_UNKNOWN)
2933         {
2934           gfc_error ("END tag label %d at %L not defined",
2935                       dt->end->value, &dt->end_where);
2936           return FAILURE;
2937         }
2938     }
2939
2940   if (dt->eor)
2941     {
2942       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2943         return FAILURE;
2944       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2945         {
2946           gfc_error ("EOR tag label %d at %L not defined",
2947                       dt->eor->value, &dt->eor_where);
2948           return FAILURE;
2949         }
2950     }
2951
2952   /* Check the format label actually exists.  */
2953   if (dt->format_label && dt->format_label != &format_asterisk
2954       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2955     {
2956       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2957                  &dt->format_label->where);
2958       return FAILURE;
2959     }
2960
2961   return SUCCESS;
2962 }
2963
2964
2965 /* Given an io_kind, return its name.  */
2966
2967 static const char *
2968 io_kind_name (io_kind k)
2969 {
2970   const char *name;
2971
2972   switch (k)
2973     {
2974     case M_READ:
2975       name = "READ";
2976       break;
2977     case M_WRITE:
2978       name = "WRITE";
2979       break;
2980     case M_PRINT:
2981       name = "PRINT";
2982       break;
2983     case M_INQUIRE:
2984       name = "INQUIRE";
2985       break;
2986     default:
2987       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2988     }
2989
2990   return name;
2991 }
2992
2993
2994 /* Match an IO iteration statement of the form:
2995
2996    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2997
2998    which is equivalent to a single IO element.  This function is
2999    mutually recursive with match_io_element().  */
3000
3001 static match match_io_element (io_kind, gfc_code **);
3002
3003 static match
3004 match_io_iterator (io_kind k, gfc_code **result)
3005 {
3006   gfc_code *head, *tail, *new_code;
3007   gfc_iterator *iter;
3008   locus old_loc;
3009   match m;
3010   int n;
3011
3012   iter = NULL;
3013   head = NULL;
3014   old_loc = gfc_current_locus;
3015
3016   if (gfc_match_char ('(') != MATCH_YES)
3017     return MATCH_NO;
3018
3019   m = match_io_element (k, &head);
3020   tail = head;
3021
3022   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3023     {
3024       m = MATCH_NO;
3025       goto cleanup;
3026     }
3027
3028   /* Can't be anything but an IO iterator.  Build a list.  */
3029   iter = gfc_get_iterator ();
3030
3031   for (n = 1;; n++)
3032     {
3033       m = gfc_match_iterator (iter, 0);
3034       if (m == MATCH_ERROR)
3035         goto cleanup;
3036       if (m == MATCH_YES)
3037         {
3038           gfc_check_do_variable (iter->var->symtree);
3039           break;
3040         }
3041
3042       m = match_io_element (k, &new_code);
3043       if (m == MATCH_ERROR)
3044         goto cleanup;
3045       if (m == MATCH_NO)
3046         {
3047           if (n > 2)
3048             goto syntax;
3049           goto cleanup;
3050         }
3051
3052       tail = gfc_append_code (tail, new_code);
3053
3054       if (gfc_match_char (',') != MATCH_YES)
3055         {
3056           if (n > 2)
3057             goto syntax;
3058           m = MATCH_NO;
3059           goto cleanup;
3060         }
3061     }
3062
3063   if (gfc_match_char (')') != MATCH_YES)
3064     goto syntax;
3065
3066   new_code = gfc_get_code ();
3067   new_code->op = EXEC_DO;
3068   new_code->ext.iterator = iter;
3069
3070   new_code->block = gfc_get_code ();
3071   new_code->block->op = EXEC_DO;
3072   new_code->block->next = head;
3073
3074   *result = new_code;
3075   return MATCH_YES;
3076
3077 syntax:
3078   gfc_error ("Syntax error in I/O iterator at %C");
3079   m = MATCH_ERROR;
3080
3081 cleanup:
3082   gfc_free_iterator (iter, 1);
3083   gfc_free_statements (head);
3084   gfc_current_locus = old_loc;
3085   return m;
3086 }
3087
3088
3089 /* Match a single element of an IO list, which is either a single
3090    expression or an IO Iterator.  */
3091
3092 static match
3093 match_io_element (io_kind k, gfc_code **cpp)
3094 {
3095   gfc_expr *expr;
3096   gfc_code *cp;
3097   match m;
3098
3099   expr = NULL;
3100
3101   m = match_io_iterator (k, cpp);
3102   if (m == MATCH_YES)
3103     return MATCH_YES;
3104
3105   if (k == M_READ)
3106     {
3107       m = gfc_match_variable (&expr, 0);
3108       if (m == MATCH_NO)
3109         gfc_error ("Expected variable in READ statement at %C");
3110     }
3111   else
3112     {
3113       m = gfc_match_expr (&expr);
3114       if (m == MATCH_NO)
3115         gfc_error ("Expected expression in %s statement at %C",
3116                    io_kind_name (k));
3117     }
3118
3119   if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3120     m = MATCH_ERROR;
3121
3122   if (m != MATCH_YES)
3123     {
3124       gfc_free_expr (expr);
3125       return MATCH_ERROR;
3126     }
3127
3128   cp = gfc_get_code ();
3129   cp->op = EXEC_TRANSFER;
3130   cp->expr1 = expr;
3131   if (k != M_INQUIRE)
3132     cp->ext.dt = current_dt;
3133
3134   *cpp = cp;
3135   return MATCH_YES;
3136 }
3137
3138
3139 /* Match an I/O list, building gfc_code structures as we go.  */
3140
3141 static match
3142 match_io_list (io_kind k, gfc_code **head_p)
3143 {
3144   gfc_code *head, *tail, *new_code;
3145   match m;
3146
3147   *head_p = head = tail = NULL;
3148   if (gfc_match_eos () == MATCH_YES)
3149     return MATCH_YES;
3150
3151   for (;;)
3152     {
3153       m = match_io_element (k, &new_code);
3154       if (m == MATCH_ERROR)
3155         goto cleanup;
3156       if (m == MATCH_NO)
3157         goto syntax;
3158
3159       tail = gfc_append_code (tail, new_code);
3160       if (head == NULL)
3161         head = new_code;
3162
3163       if (gfc_match_eos () == MATCH_YES)
3164         break;
3165       if (gfc_match_char (',') != MATCH_YES)
3166         goto syntax;
3167     }
3168
3169   *head_p = head;
3170   return MATCH_YES;
3171
3172 syntax:
3173   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3174
3175 cleanup:
3176   gfc_free_statements (head);
3177   return MATCH_ERROR;
3178 }
3179
3180
3181 /* Attach the data transfer end node.  */
3182
3183 static void
3184 terminate_io (gfc_code *io_code)
3185 {
3186   gfc_code *c;
3187
3188   if (io_code == NULL)
3189     io_code = new_st.block;
3190
3191   c = gfc_get_code ();
3192   c->op = EXEC_DT_END;
3193
3194   /* Point to structure that is already there */
3195   c->ext.dt = new_st.ext.dt;
3196   gfc_append_code (io_code, c);
3197 }
3198
3199
3200 /* Check the constraints for a data transfer statement.  The majority of the
3201    constraints appearing in 9.4 of the standard appear here.  Some are handled
3202    in resolve_tag and others in gfc_resolve_dt.  */
3203
3204 static match
3205 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3206                       locus *spec_end)
3207 {
3208 #define io_constraint(condition,msg,arg)\
3209 if (condition) \
3210   {\
3211     gfc_error(msg,arg);\
3212     m = MATCH_ERROR;\
3213   }
3214
3215   match m;
3216   gfc_expr *expr;
3217   gfc_symbol *sym = NULL;
3218   bool warn, unformatted;
3219
3220   warn = (dt->err || dt->iostat) ? true : false;
3221   unformatted = dt->format_expr == NULL && dt->format_label == NULL
3222                 && dt->namelist == NULL;
3223
3224   m = MATCH_YES;
3225
3226   expr = dt->io_unit;
3227   if (expr && expr->expr_type == EXPR_VARIABLE
3228       && expr->ts.type == BT_CHARACTER)
3229     {
3230       sym = expr->symtree->n.sym;
3231
3232       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3233                      "Internal file at %L must not be INTENT(IN)",
3234                      &expr->where);
3235
3236       io_constraint (gfc_has_vector_index (dt->io_unit),
3237                      "Internal file incompatible with vector subscript at %L",
3238                      &expr->where);
3239
3240       io_constraint (dt->rec != NULL,
3241                      "REC tag at %L is incompatible with internal file",
3242                      &dt->rec->where);
3243
3244       io_constraint (dt->pos != NULL,
3245                      "POS tag at %L is incompatible with internal file",
3246                      &dt->pos->where);
3247
3248       io_constraint (unformatted,
3249                      "Unformatted I/O not allowed with internal unit at %L",
3250                      &dt->io_unit->where);
3251
3252       io_constraint (dt->asynchronous != NULL,
3253                      "ASYNCHRONOUS tag at %L not allowed with internal file",
3254                      &dt->asynchronous->where);
3255
3256       if (dt->namelist != NULL)
3257         {
3258           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
3259                               "at %L with namelist", &expr->where)
3260               == FAILURE)
3261             m = MATCH_ERROR;
3262         }
3263
3264       io_constraint (dt->advance != NULL,
3265                      "ADVANCE tag at %L is incompatible with internal file",
3266                      &dt->advance->where);
3267     }
3268
3269   if (expr && expr->ts.type != BT_CHARACTER)
3270     {
3271
3272       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3273                      "IO UNIT in %s statement at %C must be "
3274                      "an internal file in a PURE procedure",
3275                      io_kind_name (k));
3276
3277       if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
3278         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3279
3280     }
3281
3282   if (k != M_READ)
3283     {
3284       io_constraint (dt->end, "END tag not allowed with output at %L",
3285                      &dt->end_where);
3286
3287       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3288                      &dt->eor_where);
3289
3290       io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3291                      &dt->blank->where);
3292
3293       io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3294                      &dt->pad->where);
3295
3296       io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3297                      &dt->size->where);
3298     }
3299   else
3300     {
3301       io_constraint (dt->size && dt->advance == NULL,
3302                      "SIZE tag at %L requires an ADVANCE tag",
3303                      &dt->size->where);
3304
3305       io_constraint (dt->eor && dt->advance == NULL,
3306                      "EOR tag at %L requires an ADVANCE tag",
3307                      &dt->eor_where);
3308     }
3309
3310   if (dt->asynchronous)
3311     {
3312       static const char * asynchronous[] = { "YES", "NO", NULL };
3313
3314       if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3315         {
3316           gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3317                      "expression", &dt->asynchronous->where);
3318           return MATCH_ERROR;
3319         }
3320
3321       if (!compare_to_allowed_values
3322                 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3323                  dt->asynchronous->value.character.string,
3324                  io_kind_name (k), warn))
3325         return MATCH_ERROR;
3326     }
3327
3328   if (dt->id)
3329     {
3330       bool not_yes
3331         = !dt->asynchronous
3332           || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3333           || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3334                                    "yes", 3) != 0;
3335       io_constraint (not_yes,
3336                      "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3337                      "specifier", &dt->id->where);
3338     }
3339
3340   if (dt->decimal)
3341     {
3342       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3343           "not allowed in Fortran 95") == FAILURE)
3344         return MATCH_ERROR;
3345
3346       if (dt->decimal->expr_type == EXPR_CONSTANT)
3347         {
3348           static const char * decimal[] = { "COMMA", "POINT", NULL };
3349
3350           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3351                                           dt->decimal->value.character.string,
3352                                           io_kind_name (k), warn))
3353             return MATCH_ERROR;
3354
3355           io_constraint (unformatted,
3356                          "the DECIMAL= specifier at %L must be with an "
3357                          "explicit format expression", &dt->decimal->where);
3358         }
3359     }
3360
3361   if (dt->blank)
3362     {
3363       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3364           "not allowed in Fortran 95") == FAILURE)
3365         return MATCH_ERROR;
3366
3367       if (dt->blank->expr_type == EXPR_CONSTANT)
3368         {
3369           static const char * blank[] = { "NULL", "ZERO", NULL };
3370
3371           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3372                                           dt->blank->value.character.string,
3373                                           io_kind_name (k), warn))
3374             return MATCH_ERROR;
3375
3376           io_constraint (unformatted,
3377                          "the BLANK= specifier at %L must be with an "
3378                          "explicit format expression", &dt->blank->where);
3379         }
3380     }
3381
3382   if (dt->pad)
3383     {
3384       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3385           "not allowed in Fortran 95") == FAILURE)
3386         return MATCH_ERROR;
3387
3388       if (dt->pad->expr_type == EXPR_CONSTANT)
3389         {
3390           static const char * pad[] = { "YES", "NO", NULL };
3391
3392           if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3393                                           dt->pad->value.character.string,
3394                                           io_kind_name (k), warn))
3395             return MATCH_ERROR;
3396
3397           io_constraint (unformatted,
3398                          "the PAD= specifier at %L must be with an "
3399                          "explicit format expression", &dt->pad->where);
3400         }
3401     }
3402
3403   if (dt->round)
3404     {
3405       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3406           "not allowed in Fortran 95") == FAILURE)
3407         return MATCH_ERROR;
3408
3409       if (dt->round->expr_type == EXPR_CONSTANT)
3410         {
3411           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3412                                           "COMPATIBLE", "PROCESSOR_DEFINED",
3413                                           NULL };
3414
3415           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3416                                           dt->round->value.character.string,
3417                                           io_kind_name (k), warn))
3418             return MATCH_ERROR;
3419         }
3420     }
3421
3422   if (dt->sign)
3423     {
3424       /* When implemented, change the following to use gfc_notify_std F2003.
3425       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3426           "not allowed in Fortran 95") == FAILURE)
3427         return MATCH_ERROR;  */
3428       if (dt->sign->expr_type == EXPR_CONSTANT)
3429         {
3430           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3431                                          NULL };
3432
3433           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3434                                       dt->sign->value.character.string,
3435                                       io_kind_name (k), warn))
3436             return MATCH_ERROR;
3437
3438           io_constraint (unformatted,
3439                          "SIGN= specifier at %L must be with an "
3440                          "explicit format expression", &dt->sign->where);
3441
3442           io_constraint (k == M_READ,
3443                          "SIGN= specifier at %L not allowed in a "
3444                          "READ statement", &dt->sign->where);
3445         }
3446     }
3447
3448   if (dt->delim)
3449     {
3450       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3451           "not allowed in Fortran 95") == FAILURE)
3452         return MATCH_ERROR;
3453
3454       if (dt->delim->expr_type == EXPR_CONSTANT)
3455         {
3456           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3457
3458           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3459                                           dt->delim->value.character.string,
3460                                           io_kind_name (k), warn))
3461             return MATCH_ERROR;
3462
3463           io_constraint (k == M_READ,
3464                          "DELIM= specifier at %L not allowed in a "
3465                          "READ statement", &dt->delim->where);
3466
3467           io_constraint (dt->format_label != &format_asterisk
3468                          && dt->namelist == NULL,
3469                          "DELIM= specifier at %L must have FMT=*",
3470                          &dt->delim->where);
3471
3472           io_constraint (unformatted && dt->namelist == NULL,
3473                          "DELIM= specifier at %L must be with FMT=* or "
3474                          "NML= specifier ", &dt->delim->where);
3475         }
3476     }
3477
3478   if (dt->namelist)
3479     {
3480       io_constraint (io_code && dt->namelist,
3481                      "NAMELIST cannot be followed by IO-list at %L",
3482                      &io_code->loc);
3483
3484       io_constraint (dt->format_expr,
3485                      "IO spec-list cannot contain both NAMELIST group name "
3486                      "and format specification at %L",
3487                      &dt->format_expr->where);
3488
3489       io_constraint (dt->format_label,
3490                      "IO spec-list cannot contain both NAMELIST group name "
3491                      "and format label at %L", spec_end);
3492
3493       io_constraint (dt->rec,
3494                      "NAMELIST IO is not allowed with a REC= specifier "
3495                      "at %L", &dt->rec->where);
3496
3497       io_constraint (dt->advance,
3498                      "NAMELIST IO is not allowed with a ADVANCE= specifier "
3499                      "at %L", &dt->advance->where);
3500     }
3501
3502   if (dt->rec)
3503     {
3504       io_constraint (dt->end,
3505                      "An END tag is not allowed with a "
3506                      "REC= specifier at %L", &dt->end_where);
3507
3508       io_constraint (dt->format_label == &format_asterisk,
3509                      "FMT=* is not allowed with a REC= specifier "
3510                      "at %L", spec_end);
3511
3512       io_constraint (dt->pos,
3513                      "POS= is not allowed with REC= specifier "
3514                      "at %L", &dt->pos->where);
3515     }
3516
3517   if (dt->advance)
3518     {
3519       int not_yes, not_no;
3520       expr = dt->advance;
3521
3522       io_constraint (dt->format_label == &format_asterisk,
3523                      "List directed format(*) is not allowed with a "
3524                      "ADVANCE= specifier at %L.", &expr->where);
3525
3526       io_constraint (unformatted,
3527                      "the ADVANCE= specifier at %L must appear with an "
3528                      "explicit format expression", &expr->where);
3529
3530       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3531         {
3532           const gfc_char_t *advance = expr->value.character.string;
3533           not_no = gfc_wide_strlen (advance) != 2
3534                    || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3535           not_yes = gfc_wide_strlen (advance) != 3
3536                     || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3537         }
3538       else
3539         {
3540           not_no = 0;
3541           not_yes = 0;
3542         }
3543
3544       io_constraint (not_no && not_yes,
3545                      "ADVANCE= specifier at %L must have value = "
3546                      "YES or NO.", &expr->where);
3547
3548       io_constraint (dt->size && not_no && k == M_READ,
3549                      "SIZE tag at %L requires an ADVANCE = 'NO'",
3550                      &dt->size->where);
3551
3552       io_constraint (dt->eor && not_no && k == M_READ,
3553                      "EOR tag at %L requires an ADVANCE = 'NO'",
3554                      &dt->eor_where);
3555     }
3556
3557   expr = dt->format_expr;
3558   if (gfc_simplify_expr (expr, 0) == FAILURE
3559       || check_format_string (expr, k == M_READ) == FAILURE)
3560     return MATCH_ERROR;
3561
3562   return m;
3563 }
3564 #undef io_constraint
3565
3566
3567 /* Match a READ, WRITE or PRINT statement.  */
3568
3569 static match
3570 match_io (io_kind k)
3571 {
3572   char name[GFC_MAX_SYMBOL_LEN + 1];
3573   gfc_code *io_code;
3574   gfc_symbol *sym;
3575   int comma_flag;
3576   locus where;
3577   locus spec_end;
3578   gfc_dt *dt;
3579   match m;
3580
3581   where = gfc_current_locus;
3582   comma_flag = 0;
3583   current_dt = dt = XCNEW (gfc_dt);
3584   m = gfc_match_char ('(');
3585   if (m == MATCH_NO)
3586     {
3587       where = gfc_current_locus;
3588       if (k == M_WRITE)
3589         goto syntax;
3590       else if (k == M_PRINT)
3591         {
3592           /* Treat the non-standard case of PRINT namelist.  */
3593           if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3594               && gfc_match_name (name) == MATCH_YES)
3595             {
3596               gfc_find_symbol (name, NULL, 1, &sym);
3597               if (sym && sym->attr.flavor == FL_NAMELIST)
3598                 {
3599                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3600                                       "%C is an extension") == FAILURE)
3601                     {
3602                       m = MATCH_ERROR;
3603                       goto cleanup;
3604                     }
3605
3606                   dt->io_unit = default_unit (k);
3607                   dt->namelist = sym;
3608                   goto get_io_list;
3609                 }
3610               else
3611                 gfc_current_locus = where;
3612             }
3613         }
3614
3615       if (gfc_current_form == FORM_FREE)
3616         {
3617           char c = gfc_peek_ascii_char ();
3618           if (c != ' ' && c != '*' && c != '\'' && c != '"')
3619             {
3620               m = MATCH_NO;
3621               goto cleanup;
3622             }
3623         }
3624
3625       m = match_dt_format (dt);
3626       if (m == MATCH_ERROR)
3627         goto cleanup;
3628       if (m == MATCH_NO)
3629         goto syntax;
3630
3631       comma_flag = 1;
3632       dt->io_unit = default_unit (k);
3633       goto get_io_list;
3634     }
3635   else
3636     {
3637       /* Before issuing an error for a malformed 'print (1,*)' type of
3638          error, check for a default-char-expr of the form ('(I0)').  */
3639       if (k == M_PRINT && m == MATCH_YES)
3640         {
3641           /* Reset current locus to get the initial '(' in an expression.  */
3642           gfc_current_locus = where;
3643           dt->format_expr = NULL;
3644           m = match_dt_format (dt);
3645
3646           if (m == MATCH_ERROR)
3647             goto cleanup;
3648           if (m == MATCH_NO || dt->format_expr == NULL)
3649             goto syntax;
3650
3651           comma_flag = 1;
3652           dt->io_unit = default_unit (k);
3653           goto get_io_list;
3654         }
3655     }
3656
3657   /* Match a control list */
3658   if (match_dt_element (k, dt) == MATCH_YES)
3659     goto next;
3660   if (match_dt_unit (k, dt) != MATCH_YES)
3661     goto loop;
3662
3663   if (gfc_match_char (')') == MATCH_YES)
3664     goto get_io_list;
3665   if (gfc_match_char (',') != MATCH_YES)
3666     goto syntax;
3667
3668   m = match_dt_element (k, dt);
3669   if (m == MATCH_YES)
3670     goto next;
3671   if (m == MATCH_ERROR)
3672     goto cleanup;
3673
3674   m = match_dt_format (dt);
3675   if (m == MATCH_YES)
3676     goto next;
3677   if (m == MATCH_ERROR)
3678     goto cleanup;
3679
3680   where = gfc_current_locus;
3681
3682   m = gfc_match_name (name);
3683   if (m == MATCH_YES)
3684     {
3685       gfc_find_symbol (name, NULL, 1, &sym);
3686       if (sym && sym->attr.flavor == FL_NAMELIST)
3687         {
3688           dt->namelist = sym;
3689           if (k == M_READ && check_namelist (sym))
3690             {
3691               m = MATCH_ERROR;
3692               goto cleanup;
3693             }
3694           goto next;
3695         }
3696     }
3697
3698   gfc_current_locus = where;
3699
3700   goto loop;                    /* No matches, try regular elements */
3701
3702 next:
3703   if (gfc_match_char (')') == MATCH_YES)
3704     goto get_io_list;
3705   if (gfc_match_char (',') != MATCH_YES)
3706     goto syntax;
3707
3708 loop:
3709   for (;;)
3710     {
3711       m = match_dt_element (k, dt);
3712       if (m == MATCH_NO)
3713         goto syntax;
3714       if (m == MATCH_ERROR)
3715         goto cleanup;
3716
3717       if (gfc_match_char (')') == MATCH_YES)
3718         break;
3719       if (gfc_match_char (',') != MATCH_YES)
3720         goto syntax;
3721     }
3722
3723 get_io_list:
3724
3725   /* Used in check_io_constraints, where no locus is available.  */
3726   spec_end = gfc_current_locus;
3727
3728   /* Save the IO kind for later use.  */
3729   dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
3730
3731   /* Optional leading comma (non-standard).  We use a gfc_expr structure here
3732      to save the locus.  This is used later when resolving transfer statements
3733      that might have a format expression without unit number.  */
3734   if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3735     dt->extra_comma = dt->dt_io_kind;
3736
3737   io_code = NULL;
3738   if (gfc_match_eos () != MATCH_YES)
3739     {
3740       if (comma_flag && gfc_match_char (',') != MATCH_YES)
3741         {
3742           gfc_error ("Expected comma in I/O list at %C");
3743           m = MATCH_ERROR;
3744           goto cleanup;
3745         }
3746
3747       m = match_io_list (k, &io_code);
3748       if (m == MATCH_ERROR)
3749         goto cleanup;
3750       if (m == MATCH_NO)
3751         goto syntax;
3752     }
3753
3754   /* A full IO statement has been matched.  Check the constraints.  spec_end is
3755      supplied for cases where no locus is supplied.  */
3756   m = check_io_constraints (k, dt, io_code, &spec_end);
3757
3758   if (m == MATCH_ERROR)
3759     goto cleanup;
3760
3761   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3762   new_st.ext.dt = dt;
3763   new_st.block = gfc_get_code ();
3764   new_st.block->op = new_st.op;
3765   new_st.block->next = io_code;
3766
3767   terminate_io (io_code);
3768
3769   return MATCH_YES;
3770
3771 syntax:
3772   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3773   m = MATCH_ERROR;
3774
3775 cleanup:
3776   gfc_free_dt (dt);
3777   return m;
3778 }
3779
3780
3781 match
3782 gfc_match_read (void)
3783 {
3784   return match_io (M_READ);
3785 }
3786
3787
3788 match
3789 gfc_match_write (void)
3790 {
3791   return match_io (M_WRITE);
3792 }
3793
3794
3795 match
3796 gfc_match_print (void)
3797 {
3798   match m;
3799
3800   m = match_io (M_PRINT);
3801   if (m != MATCH_YES)
3802     return m;
3803
3804   if (gfc_pure (NULL))
3805     {
3806       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3807       return MATCH_ERROR;
3808     }
3809
3810   if (gfc_implicit_pure (NULL))
3811     gfc_current_ns->proc_name->attr.implicit_pure = 0;
3812
3813   return MATCH_YES;
3814 }
3815
3816
3817 /* Free a gfc_inquire structure.  */
3818
3819 void
3820 gfc_free_inquire (gfc_inquire *inquire)
3821 {
3822
3823   if (inquire == NULL)
3824     return;
3825
3826   gfc_free_expr (inquire->unit);
3827   gfc_free_expr (inquire->file);
3828   gfc_free_expr (inquire->iomsg);
3829   gfc_free_expr (inquire->iostat);
3830   gfc_free_expr (inquire->exist);
3831   gfc_free_expr (inquire->opened);
3832   gfc_free_expr (inquire->number);
3833   gfc_free_expr (inquire->named);
3834   gfc_free_expr (inquire->name);
3835   gfc_free_expr (inquire->access);
3836   gfc_free_expr (inquire->sequential);
3837   gfc_free_expr (inquire->direct);
3838   gfc_free_expr (inquire->form);
3839   gfc_free_expr (inquire->formatted);
3840   gfc_free_expr (inquire->unformatted);
3841   gfc_free_expr (inquire->recl);
3842   gfc_free_expr (inquire->nextrec);
3843   gfc_free_expr (inquire->blank);
3844   gfc_free_expr (inquire->position);
3845   gfc_free_expr (inquire->action);
3846   gfc_free_expr (inquire->read);
3847   gfc_free_expr (inquire->write);
3848   gfc_free_expr (inquire->readwrite);
3849   gfc_free_expr (inquire->delim);
3850   gfc_free_expr (inquire->encoding);
3851   gfc_free_expr (inquire->pad);
3852   gfc_free_expr (inquire->iolength);
3853   gfc_free_expr (inquire->convert);
3854   gfc_free_expr (inquire->strm_pos);
3855   gfc_free_expr (inquire->asynchronous);
3856   gfc_free_expr (inquire->decimal);
3857   gfc_free_expr (inquire->pending);
3858   gfc_free_expr (inquire->id);
3859   gfc_free_expr (inquire->sign);
3860   gfc_free_expr (inquire->size);
3861   gfc_free_expr (inquire->round);
3862   free (inquire);
3863 }
3864
3865
3866 /* Match an element of an INQUIRE statement.  */
3867
3868 #define RETM   if (m != MATCH_NO) return m;
3869
3870 static match
3871 match_inquire_element (gfc_inquire *inquire)
3872 {
3873   match m;
3874
3875   m = match_etag (&tag_unit, &inquire->unit);
3876   RETM m = match_etag (&tag_file, &inquire->file);
3877   RETM m = match_ltag (&tag_err, &inquire->err);
3878   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3879   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3880   RETM m = match_vtag (&tag_exist, &inquire->exist);
3881   RETM m = match_vtag (&tag_opened, &inquire->opened);
3882   RETM m = match_vtag (&tag_named, &inquire->named);
3883   RETM m = match_vtag (&tag_name, &inquire->name);
3884   RETM m = match_out_tag (&tag_number, &inquire->number);
3885   RETM m = match_vtag (&tag_s_access, &inquire->access);
3886   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3887   RETM m = match_vtag (&tag_direct, &inquire->direct);
3888   RETM m = match_vtag (&tag_s_form, &inquire->form);
3889   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3890   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3891   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3892   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3893   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3894   RETM m = match_vtag (&tag_s_position, &inquire->position);
3895   RETM m = match_vtag (&tag_s_action, &inquire->action);
3896   RETM m = match_vtag (&tag_read, &inquire->read);
3897   RETM m = match_vtag (&tag_write, &inquire->write);
3898   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3899   RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3900   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3901   RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3902   RETM m = match_vtag (&tag_size, &inquire->size);
3903   RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3904   RETM m = match_vtag (&tag_s_round, &inquire->round);
3905   RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3906   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3907   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3908   RETM m = match_vtag (&tag_convert, &inquire->convert);
3909   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3910   RETM m = match_vtag (&tag_pending, &inquire->pending);
3911   RETM m = match_vtag (&tag_id, &inquire->id);
3912   RETM return MATCH_NO;
3913 }
3914
3915 #undef RETM
3916
3917
3918 match
3919 gfc_match_inquire (void)
3920 {
3921   gfc_inquire *inquire;
3922   gfc_code *code;
3923   match m;
3924   locus loc;
3925
3926   m = gfc_match_char ('(');
3927   if (m == MATCH_NO)
3928     return m;
3929
3930   inquire = XCNEW (gfc_inquire);
3931
3932   loc = gfc_current_locus;
3933
3934   m = match_inquire_element (inquire);
3935   if (m == MATCH_ERROR)
3936     goto cleanup;
3937   if (m == MATCH_NO)
3938     {
3939       m = gfc_match_expr (&inquire->unit);
3940       if (m == MATCH_ERROR)
3941         goto cleanup;
3942       if (m == MATCH_NO)
3943         goto syntax;
3944     }
3945
3946   /* See if we have the IOLENGTH form of the inquire statement.  */
3947   if (inquire->iolength != NULL)
3948     {
3949       if (gfc_match_char (')') != MATCH_YES)
3950         goto syntax;
3951
3952       m = match_io_list (M_INQUIRE, &code);
3953       if (m == MATCH_ERROR)
3954         goto cleanup;
3955       if (m == MATCH_NO)
3956         goto syntax;
3957
3958       new_st.op = EXEC_IOLENGTH;
3959       new_st.expr1 = inquire->iolength;
3960       new_st.ext.inquire = inquire;
3961
3962       if (gfc_pure (NULL))
3963         {
3964           gfc_free_statements (code);
3965           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3966           return MATCH_ERROR;
3967         }
3968
3969       if (gfc_implicit_pure (NULL))
3970         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3971
3972       new_st.block = gfc_get_code ();
3973       new_st.block->op = EXEC_IOLENGTH;
3974       terminate_io (code);
3975       new_st.block->next = code;
3976       return MATCH_YES;
3977     }
3978
3979   /* At this point, we have the non-IOLENGTH inquire statement.  */
3980   for (;;)
3981     {
3982       if (gfc_match_char (')') == MATCH_YES)
3983         break;
3984       if (gfc_match_char (',') != MATCH_YES)
3985         goto syntax;
3986
3987       m = match_inquire_element (inquire);
3988       if (m == MATCH_ERROR)
3989         goto cleanup;
3990       if (m == MATCH_NO)
3991         goto syntax;
3992
3993       if (inquire->iolength != NULL)
3994         {
3995           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3996           goto cleanup;
3997         }
3998     }
3999
4000   if (gfc_match_eos () != MATCH_YES)
4001     goto syntax;
4002
4003   if (inquire->unit != NULL && inquire->file != NULL)
4004     {
4005       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4006                  "UNIT specifiers", &loc);
4007       goto cleanup;
4008     }
4009
4010   if (inquire->unit == NULL && inquire->file == NULL)
4011     {
4012       gfc_error ("INQUIRE statement at %L requires either FILE or "
4013                  "UNIT specifier", &loc);
4014       goto cleanup;
4015     }
4016
4017   if (gfc_pure (NULL))
4018     {
4019       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4020       goto cleanup;
4021     }
4022
4023   if (gfc_implicit_pure (NULL))
4024     gfc_current_ns->proc_name->attr.implicit_pure = 0;
4025
4026   if (inquire->id != NULL && inquire->pending == NULL)
4027     {
4028       gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4029                  "the ID= specifier", &loc);
4030       goto cleanup;
4031     }
4032
4033   new_st.op = EXEC_INQUIRE;
4034   new_st.ext.inquire = inquire;
4035   return MATCH_YES;
4036
4037 syntax:
4038   gfc_syntax_error (ST_INQUIRE);
4039
4040 cleanup:
4041   gfc_free_inquire (inquire);
4042   return MATCH_ERROR;
4043 }
4044
4045
4046 /* Resolve everything in a gfc_inquire structure.  */
4047
4048 gfc_try
4049 gfc_resolve_inquire (gfc_inquire *inquire)
4050 {
4051   RESOLVE_TAG (&tag_unit, inquire->unit);
4052   RESOLVE_TAG (&tag_file, inquire->file);
4053   RESOLVE_TAG (&tag_id, inquire->id);
4054
4055   /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4056      contexts.  Thus, use an extended RESOLVE_TAG macro for that.  */
4057 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4058   RESOLVE_TAG (tag, expr); \
4059   if (expr) \
4060     { \
4061       char context[64]; \
4062       sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4063       if (gfc_check_vardef_context ((expr), false, false, context) == FAILURE) \
4064         return FAILURE; \
4065     }
4066   INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4067   INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4068   INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4069   INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4070   INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4071   INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4072   INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4073   INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4074   INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4075   INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4076   INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4077   INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4078   INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4079   INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4080   INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4081   INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4082   INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4083   INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4084   INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4085   INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4086   INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4087   INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4088   INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4089   INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4090   INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4091   INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4092   INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4093   INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4094   INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4095   INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4096   INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4097   INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4098   INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4099   INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4100 #undef INQUIRE_RESOLVE_TAG
4101
4102   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
4103     return FAILURE;
4104
4105   return SUCCESS;
4106 }
4107
4108
4109 void
4110 gfc_free_wait (gfc_wait *wait)
4111 {
4112   if (wait == NULL)
4113     return;
4114
4115   gfc_free_expr (wait->unit);
4116   gfc_free_expr (wait->iostat);
4117   gfc_free_expr (wait->iomsg);
4118   gfc_free_expr (wait->id);
4119 }
4120
4121
4122 gfc_try
4123 gfc_resolve_wait (gfc_wait *wait)
4124 {
4125   RESOLVE_TAG (&tag_unit, wait->unit);
4126   RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4127   RESOLVE_TAG (&tag_iostat, wait->iostat);
4128   RESOLVE_TAG (&tag_id, wait->id);
4129
4130   if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
4131     return FAILURE;
4132
4133   if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
4134     return FAILURE;
4135
4136   return SUCCESS;
4137 }
4138
4139 /* Match an element of a WAIT statement.  */
4140
4141 #define RETM   if (m != MATCH_NO) return m;
4142
4143 static match
4144 match_wait_element (gfc_wait *wait)
4145 {
4146   match m;
4147
4148   m = match_etag (&tag_unit, &wait->unit);
4149   RETM m = match_ltag (&tag_err, &wait->err);
4150   RETM m = match_ltag (&tag_end, &wait->eor);
4151   RETM m = match_ltag (&tag_eor, &wait->end);
4152   RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4153   RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4154   RETM m = match_etag (&tag_id, &wait->id);
4155   RETM return MATCH_NO;
4156 }
4157
4158 #undef RETM
4159
4160
4161 match
4162 gfc_match_wait (void)
4163 {
4164   gfc_wait *wait;
4165   match m;
4166
4167   m = gfc_match_char ('(');
4168   if (m == MATCH_NO)
4169     return m;
4170
4171   wait = XCNEW (gfc_wait);
4172
4173   m = match_wait_element (wait);
4174   if (m == MATCH_ERROR)
4175     goto cleanup;
4176   if (m == MATCH_NO)
4177     {
4178       m = gfc_match_expr (&wait->unit);
4179       if (m == MATCH_ERROR)
4180         goto cleanup;
4181       if (m == MATCH_NO)
4182         goto syntax;
4183     }
4184
4185   for (;;)
4186     {
4187       if (gfc_match_char (')') == MATCH_YES)
4188         break;
4189       if (gfc_match_char (',') != MATCH_YES)
4190         goto syntax;
4191
4192       m = match_wait_element (wait);
4193       if (m == MATCH_ERROR)
4194         goto cleanup;
4195       if (m == MATCH_NO)
4196         goto syntax;
4197     }
4198
4199   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
4200           "not allowed in Fortran 95") == FAILURE)
4201     goto cleanup;
4202
4203   if (gfc_pure (NULL))
4204     {
4205       gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4206       goto cleanup;
4207     }
4208
4209   if (gfc_implicit_pure (NULL))
4210     gfc_current_ns->proc_name->attr.implicit_pure = 0;
4211
4212   new_st.op = EXEC_WAIT;
4213   new_st.ext.wait = wait;
4214
4215   return MATCH_YES;
4216
4217 syntax:
4218   gfc_syntax_error (ST_WAIT);
4219
4220 cleanup:
4221   gfc_free_wait (wait);
4222   return MATCH_ERROR;
4223 }