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 (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1951           "not allowed in Fortran 95") == FAILURE)
1952         goto cleanup;
1953
1954       if (open->delim->expr_type == EXPR_CONSTANT)
1955         {
1956           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1957
1958           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1959                                           open->delim->value.character.string,
1960                                           "OPEN", warn))
1961           goto cleanup;
1962         }
1963     }
1964
1965   /* Checks on the ENCODING specifier.  */
1966   if (open->encoding)
1967     {
1968       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1969           "not allowed in Fortran 95") == FAILURE)
1970         goto cleanup;
1971
1972       if (open->encoding->expr_type == EXPR_CONSTANT)
1973         {
1974           static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1975
1976           if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1977                                           open->encoding->value.character.string,
1978                                           "OPEN", warn))
1979           goto cleanup;
1980         }
1981     }
1982
1983   /* Checks on the FORM specifier.  */
1984   if (open->form && open->form->expr_type == EXPR_CONSTANT)
1985     {
1986       static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1987
1988       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1989                                       open->form->value.character.string,
1990                                       "OPEN", warn))
1991         goto cleanup;
1992     }
1993
1994   /* Checks on the PAD specifier.  */
1995   if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1996     {
1997       static const char *pad[] = { "YES", "NO", NULL };
1998
1999       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
2000                                       open->pad->value.character.string,
2001                                       "OPEN", warn))
2002         goto cleanup;
2003     }
2004
2005   /* Checks on the POSITION specifier.  */
2006   if (open->position && open->position->expr_type == EXPR_CONSTANT)
2007     {
2008       static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
2009
2010       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2011                                       open->position->value.character.string,
2012                                       "OPEN", warn))
2013         goto cleanup;
2014     }
2015
2016   /* Checks on the ROUND specifier.  */
2017   if (open->round)
2018     {
2019       if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
2020           "not allowed in Fortran 95") == FAILURE)
2021       goto cleanup;
2022
2023       if (open->round->expr_type == EXPR_CONSTANT)
2024         {
2025           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2026                                           "COMPATIBLE", "PROCESSOR_DEFINED",
2027                                            NULL };
2028
2029           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2030                                           open->round->value.character.string,
2031                                           "OPEN", warn))
2032           goto cleanup;
2033         }
2034     }
2035
2036   /* Checks on the SIGN specifier.  */
2037   if (open->sign)
2038     {
2039       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
2040           "not allowed in Fortran 95") == FAILURE)
2041         goto cleanup;
2042
2043       if (open->sign->expr_type == EXPR_CONSTANT)
2044         {
2045           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2046                                           NULL };
2047
2048           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2049                                           open->sign->value.character.string,
2050                                           "OPEN", warn))
2051           goto cleanup;
2052         }
2053     }
2054
2055 #define warn_or_error(...) \
2056 { \
2057   if (warn) \
2058     gfc_warning (__VA_ARGS__); \
2059   else \
2060     { \
2061       gfc_error (__VA_ARGS__); \
2062       goto cleanup; \
2063     } \
2064 }
2065
2066   /* Checks on the RECL specifier.  */
2067   if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2068       && open->recl->ts.type == BT_INTEGER
2069       && mpz_sgn (open->recl->value.integer) != 1)
2070     {
2071       warn_or_error ("RECL in OPEN statement at %C must be positive");
2072     }
2073
2074   /* Checks on the STATUS specifier.  */
2075   if (open->status && open->status->expr_type == EXPR_CONSTANT)
2076     {
2077       static const char *status[] = { "OLD", "NEW", "SCRATCH",
2078         "REPLACE", "UNKNOWN", NULL };
2079
2080       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2081                                       open->status->value.character.string,
2082                                       "OPEN", warn))
2083         goto cleanup;
2084
2085       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2086          the FILE= specifier shall appear.  */
2087       if (open->file == NULL
2088           && (gfc_wide_strncasecmp (open->status->value.character.string,
2089                                     "replace", 7) == 0
2090               || gfc_wide_strncasecmp (open->status->value.character.string,
2091                                        "new", 3) == 0))
2092         {
2093           char *s = gfc_widechar_to_char (open->status->value.character.string,
2094                                           -1);
2095           warn_or_error ("The STATUS specified in OPEN statement at %C is "
2096                          "'%s' and no FILE specifier is present", s);
2097           free (s);
2098         }
2099
2100       /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2101          the FILE= specifier shall not appear.  */
2102       if (gfc_wide_strncasecmp (open->status->value.character.string,
2103                                 "scratch", 7) == 0 && open->file)
2104         {
2105           warn_or_error ("The STATUS specified in OPEN statement at %C "
2106                          "cannot have the value SCRATCH if a FILE specifier "
2107                          "is present");
2108         }
2109     }
2110
2111   /* Things that are not allowed for unformatted I/O.  */
2112   if (open->form && open->form->expr_type == EXPR_CONSTANT
2113       && (open->delim || open->decimal || open->encoding || open->round
2114           || open->sign || open->pad || open->blank)
2115       && gfc_wide_strncasecmp (open->form->value.character.string,
2116                                "unformatted", 11) == 0)
2117     {
2118       const char *spec = (open->delim ? "DELIM "
2119                                       : (open->pad ? "PAD " : open->blank
2120                                                             ? "BLANK " : ""));
2121
2122       warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2123                      "unformatted I/O", spec);
2124     }
2125
2126   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2127       && gfc_wide_strncasecmp (open->access->value.character.string,
2128                                "stream", 6) == 0)
2129     {
2130       warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2131                      "stream I/O");
2132     }
2133
2134   if (open->position
2135       && open->access && open->access->expr_type == EXPR_CONSTANT
2136       && !(gfc_wide_strncasecmp (open->access->value.character.string,
2137                                  "sequential", 10) == 0
2138            || gfc_wide_strncasecmp (open->access->value.character.string,
2139                                     "stream", 6) == 0
2140            || gfc_wide_strncasecmp (open->access->value.character.string,
2141                                     "append", 6) == 0))
2142     {
2143       warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2144                      "for stream or sequential ACCESS");
2145     }
2146
2147 #undef warn_or_error
2148
2149   new_st.op = EXEC_OPEN;
2150   new_st.ext.open = open;
2151   return MATCH_YES;
2152
2153 syntax:
2154   gfc_syntax_error (ST_OPEN);
2155
2156 cleanup:
2157   gfc_free_open (open);
2158   return MATCH_ERROR;
2159 }
2160
2161
2162 /* Free a gfc_close structure an all its expressions.  */
2163
2164 void
2165 gfc_free_close (gfc_close *close)
2166 {
2167   if (close == NULL)
2168     return;
2169
2170   gfc_free_expr (close->unit);
2171   gfc_free_expr (close->iomsg);
2172   gfc_free_expr (close->iostat);
2173   gfc_free_expr (close->status);
2174   free (close);
2175 }
2176
2177
2178 /* Match elements of a CLOSE statement.  */
2179
2180 static match
2181 match_close_element (gfc_close *close)
2182 {
2183   match m;
2184
2185   m = match_etag (&tag_unit, &close->unit);
2186   if (m != MATCH_NO)
2187     return m;
2188   m = match_etag (&tag_status, &close->status);
2189   if (m != MATCH_NO)
2190     return m;
2191   m = match_out_tag (&tag_iomsg, &close->iomsg);
2192   if (m != MATCH_NO)
2193     return m;
2194   m = match_out_tag (&tag_iostat, &close->iostat);
2195   if (m != MATCH_NO)
2196     return m;
2197   m = match_ltag (&tag_err, &close->err);
2198   if (m != MATCH_NO)
2199     return m;
2200
2201   return MATCH_NO;
2202 }
2203
2204
2205 /* Match a CLOSE statement.  */
2206
2207 match
2208 gfc_match_close (void)
2209 {
2210   gfc_close *close;
2211   match m;
2212   bool warn;
2213
2214   m = gfc_match_char ('(');
2215   if (m == MATCH_NO)
2216     return m;
2217
2218   close = XCNEW (gfc_close);
2219
2220   m = match_close_element (close);
2221
2222   if (m == MATCH_ERROR)
2223     goto cleanup;
2224   if (m == MATCH_NO)
2225     {
2226       m = gfc_match_expr (&close->unit);
2227       if (m == MATCH_NO)
2228         goto syntax;
2229       if (m == MATCH_ERROR)
2230         goto cleanup;
2231     }
2232
2233   for (;;)
2234     {
2235       if (gfc_match_char (')') == MATCH_YES)
2236         break;
2237       if (gfc_match_char (',') != MATCH_YES)
2238         goto syntax;
2239
2240       m = match_close_element (close);
2241       if (m == MATCH_ERROR)
2242         goto cleanup;
2243       if (m == MATCH_NO)
2244         goto syntax;
2245     }
2246
2247   if (gfc_match_eos () == MATCH_NO)
2248     goto syntax;
2249
2250   if (gfc_pure (NULL))
2251     {
2252       gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2253       goto cleanup;
2254     }
2255
2256   if (gfc_implicit_pure (NULL))
2257     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2258
2259   warn = (close->iostat || close->err) ? true : false;
2260
2261   /* Checks on the STATUS specifier.  */
2262   if (close->status && close->status->expr_type == EXPR_CONSTANT)
2263     {
2264       static const char *status[] = { "KEEP", "DELETE", NULL };
2265
2266       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2267                                       close->status->value.character.string,
2268                                       "CLOSE", warn))
2269         goto cleanup;
2270     }
2271
2272   new_st.op = EXEC_CLOSE;
2273   new_st.ext.close = close;
2274   return MATCH_YES;
2275
2276 syntax:
2277   gfc_syntax_error (ST_CLOSE);
2278
2279 cleanup:
2280   gfc_free_close (close);
2281   return MATCH_ERROR;
2282 }
2283
2284
2285 /* Resolve everything in a gfc_close structure.  */
2286
2287 gfc_try
2288 gfc_resolve_close (gfc_close *close)
2289 {
2290   RESOLVE_TAG (&tag_unit, close->unit);
2291   RESOLVE_TAG (&tag_iomsg, close->iomsg);
2292   RESOLVE_TAG (&tag_iostat, close->iostat);
2293   RESOLVE_TAG (&tag_status, close->status);
2294
2295   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2296     return FAILURE;
2297
2298   if (close->unit->expr_type == EXPR_CONSTANT
2299       && close->unit->ts.type == BT_INTEGER
2300       && mpz_sgn (close->unit->value.integer) < 0)
2301     {
2302       gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2303                  &close->unit->where);
2304     }
2305
2306   return SUCCESS;
2307 }
2308
2309
2310 /* Free a gfc_filepos structure.  */
2311
2312 void
2313 gfc_free_filepos (gfc_filepos *fp)
2314 {
2315   gfc_free_expr (fp->unit);
2316   gfc_free_expr (fp->iomsg);
2317   gfc_free_expr (fp->iostat);
2318   free (fp);
2319 }
2320
2321
2322 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
2323
2324 static match
2325 match_file_element (gfc_filepos *fp)
2326 {
2327   match m;
2328
2329   m = match_etag (&tag_unit, &fp->unit);
2330   if (m != MATCH_NO)
2331     return m;
2332   m = match_out_tag (&tag_iomsg, &fp->iomsg);
2333   if (m != MATCH_NO)
2334     return m;
2335   m = match_out_tag (&tag_iostat, &fp->iostat);
2336   if (m != MATCH_NO)
2337     return m;
2338   m = match_ltag (&tag_err, &fp->err);
2339   if (m != MATCH_NO)
2340     return m;
2341
2342   return MATCH_NO;
2343 }
2344
2345
2346 /* Match the second half of the file-positioning statements, REWIND,
2347    BACKSPACE, ENDFILE, or the FLUSH statement.  */
2348
2349 static match
2350 match_filepos (gfc_statement st, gfc_exec_op op)
2351 {
2352   gfc_filepos *fp;
2353   match m;
2354
2355   fp = XCNEW (gfc_filepos);
2356
2357   if (gfc_match_char ('(') == MATCH_NO)
2358     {
2359       m = gfc_match_expr (&fp->unit);
2360       if (m == MATCH_ERROR)
2361         goto cleanup;
2362       if (m == MATCH_NO)
2363         goto syntax;
2364
2365       goto done;
2366     }
2367
2368   m = match_file_element (fp);
2369   if (m == MATCH_ERROR)
2370     goto done;
2371   if (m == MATCH_NO)
2372     {
2373       m = gfc_match_expr (&fp->unit);
2374       if (m == MATCH_ERROR)
2375         goto done;
2376       if (m == MATCH_NO)
2377         goto syntax;
2378     }
2379
2380   for (;;)
2381     {
2382       if (gfc_match_char (')') == MATCH_YES)
2383         break;
2384       if (gfc_match_char (',') != MATCH_YES)
2385         goto syntax;
2386
2387       m = match_file_element (fp);
2388       if (m == MATCH_ERROR)
2389         goto cleanup;
2390       if (m == MATCH_NO)
2391         goto syntax;
2392     }
2393
2394 done:
2395   if (gfc_match_eos () != MATCH_YES)
2396     goto syntax;
2397
2398   if (gfc_pure (NULL))
2399     {
2400       gfc_error ("%s statement not allowed in PURE procedure at %C",
2401                  gfc_ascii_statement (st));
2402
2403       goto cleanup;
2404     }
2405
2406   if (gfc_implicit_pure (NULL))
2407     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2408
2409   new_st.op = op;
2410   new_st.ext.filepos = fp;
2411   return MATCH_YES;
2412
2413 syntax:
2414   gfc_syntax_error (st);
2415
2416 cleanup:
2417   gfc_free_filepos (fp);
2418   return MATCH_ERROR;
2419 }
2420
2421
2422 gfc_try
2423 gfc_resolve_filepos (gfc_filepos *fp)
2424 {
2425   RESOLVE_TAG (&tag_unit, fp->unit);
2426   RESOLVE_TAG (&tag_iostat, fp->iostat);
2427   RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2428   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2429     return FAILURE;
2430
2431   if (fp->unit->expr_type == EXPR_CONSTANT
2432       && fp->unit->ts.type == BT_INTEGER
2433       && mpz_sgn (fp->unit->value.integer) < 0)
2434     {
2435       gfc_error ("UNIT number in statement at %L must be non-negative",
2436                  &fp->unit->where);
2437     }
2438
2439   return SUCCESS;
2440 }
2441
2442
2443 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2444    and the FLUSH statement.  */
2445
2446 match
2447 gfc_match_endfile (void)
2448 {
2449   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2450 }
2451
2452 match
2453 gfc_match_backspace (void)
2454 {
2455   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2456 }
2457
2458 match
2459 gfc_match_rewind (void)
2460 {
2461   return match_filepos (ST_REWIND, EXEC_REWIND);
2462 }
2463
2464 match
2465 gfc_match_flush (void)
2466 {
2467   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2468       == FAILURE)
2469     return MATCH_ERROR;
2470
2471   return match_filepos (ST_FLUSH, EXEC_FLUSH);
2472 }
2473
2474 /******************** Data Transfer Statements *********************/
2475
2476 /* Return a default unit number.  */
2477
2478 static gfc_expr *
2479 default_unit (io_kind k)
2480 {
2481   int unit;
2482
2483   if (k == M_READ)
2484     unit = 5;
2485   else
2486     unit = 6;
2487
2488   return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2489 }
2490
2491
2492 /* Match a unit specification for a data transfer statement.  */
2493
2494 static match
2495 match_dt_unit (io_kind k, gfc_dt *dt)
2496 {
2497   gfc_expr *e;
2498
2499   if (gfc_match_char ('*') == MATCH_YES)
2500     {
2501       if (dt->io_unit != NULL)
2502         goto conflict;
2503
2504       dt->io_unit = default_unit (k);
2505       return MATCH_YES;
2506     }
2507
2508   if (gfc_match_expr (&e) == MATCH_YES)
2509     {
2510       if (dt->io_unit != NULL)
2511         {
2512           gfc_free_expr (e);
2513           goto conflict;
2514         }
2515
2516       dt->io_unit = e;
2517       return MATCH_YES;
2518     }
2519
2520   return MATCH_NO;
2521
2522 conflict:
2523   gfc_error ("Duplicate UNIT specification at %C");
2524   return MATCH_ERROR;
2525 }
2526
2527
2528 /* Match a format specification.  */
2529
2530 static match
2531 match_dt_format (gfc_dt *dt)
2532 {
2533   locus where;
2534   gfc_expr *e;
2535   gfc_st_label *label;
2536   match m;
2537
2538   where = gfc_current_locus;
2539
2540   if (gfc_match_char ('*') == MATCH_YES)
2541     {
2542       if (dt->format_expr != NULL || dt->format_label != NULL)
2543         goto conflict;
2544
2545       dt->format_label = &format_asterisk;
2546       return MATCH_YES;
2547     }
2548
2549   if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2550     {
2551       char c;
2552
2553       /* Need to check if the format label is actually either an operand
2554          to a user-defined operator or is a kind type parameter.  That is,
2555          print 2.ip.8      ! .ip. is a user-defined operator return CHARACTER.
2556          print 1_'(I0)', i ! 1_'(I0)' is a default character string.  */
2557
2558       gfc_gobble_whitespace ();
2559       c = gfc_peek_ascii_char ();
2560       if (c == '.' || c == '_')
2561         gfc_current_locus = where;
2562       else
2563         {
2564           if (dt->format_expr != NULL || dt->format_label != NULL)
2565             {
2566               gfc_free_st_label (label);
2567               goto conflict;
2568             }
2569
2570           if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2571             return MATCH_ERROR;
2572
2573           dt->format_label = label;
2574           return MATCH_YES;
2575         }
2576     }
2577   else if (m == MATCH_ERROR)
2578     /* The label was zero or too large.  Emit the correct diagnosis.  */
2579     return MATCH_ERROR;
2580
2581   if (gfc_match_expr (&e) == MATCH_YES)
2582     {
2583       if (dt->format_expr != NULL || dt->format_label != NULL)
2584         {
2585           gfc_free_expr (e);
2586           goto conflict;
2587         }
2588       dt->format_expr = e;
2589       return MATCH_YES;
2590     }
2591
2592   gfc_current_locus = where;    /* The only case where we have to restore */
2593
2594   return MATCH_NO;
2595
2596 conflict:
2597   gfc_error ("Duplicate format specification at %C");
2598   return MATCH_ERROR;
2599 }
2600
2601
2602 /* Traverse a namelist that is part of a READ statement to make sure
2603    that none of the variables in the namelist are INTENT(IN).  Returns
2604    nonzero if we find such a variable.  */
2605
2606 static int
2607 check_namelist (gfc_symbol *sym)
2608 {
2609   gfc_namelist *p;
2610
2611   for (p = sym->namelist; p; p = p->next)
2612     if (p->sym->attr.intent == INTENT_IN)
2613       {
2614         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2615                    p->sym->name, sym->name);
2616         return 1;
2617       }
2618
2619   return 0;
2620 }
2621
2622
2623 /* Match a single data transfer element.  */
2624
2625 static match
2626 match_dt_element (io_kind k, gfc_dt *dt)
2627 {
2628   char name[GFC_MAX_SYMBOL_LEN + 1];
2629   gfc_symbol *sym;
2630   match m;
2631
2632   if (gfc_match (" unit =") == MATCH_YES)
2633     {
2634       m = match_dt_unit (k, dt);
2635       if (m != MATCH_NO)
2636         return m;
2637     }
2638
2639   if (gfc_match (" fmt =") == MATCH_YES)
2640     {
2641       m = match_dt_format (dt);
2642       if (m != MATCH_NO)
2643         return m;
2644     }
2645
2646   if (gfc_match (" nml = %n", name) == MATCH_YES)
2647     {
2648       if (dt->namelist != NULL)
2649         {
2650           gfc_error ("Duplicate NML specification at %C");
2651           return MATCH_ERROR;
2652         }
2653
2654       if (gfc_find_symbol (name, NULL, 1, &sym))
2655         return MATCH_ERROR;
2656
2657       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2658         {
2659           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2660                      sym != NULL ? sym->name : name);
2661           return MATCH_ERROR;
2662         }
2663
2664       dt->namelist = sym;
2665       if (k == M_READ && check_namelist (sym))
2666         return MATCH_ERROR;
2667
2668       return MATCH_YES;
2669     }
2670
2671   m = match_etag (&tag_e_async, &dt->asynchronous);
2672   if (m != MATCH_NO)
2673     return m;
2674   m = match_etag (&tag_e_blank, &dt->blank);
2675   if (m != MATCH_NO)
2676     return m;
2677   m = match_etag (&tag_e_delim, &dt->delim);
2678   if (m != MATCH_NO)
2679     return m;
2680   m = match_etag (&tag_e_pad, &dt->pad);
2681   if (m != MATCH_NO)
2682     return m;
2683   m = match_etag (&tag_e_sign, &dt->sign);
2684   if (m != MATCH_NO)
2685     return m;
2686   m = match_etag (&tag_e_round, &dt->round);
2687   if (m != MATCH_NO)
2688     return m;
2689   m = match_out_tag (&tag_id, &dt->id);
2690   if (m != MATCH_NO)
2691     return m;
2692   m = match_etag (&tag_e_decimal, &dt->decimal);
2693   if (m != MATCH_NO)
2694     return m;
2695   m = match_etag (&tag_rec, &dt->rec);
2696   if (m != MATCH_NO)
2697     return m;
2698   m = match_etag (&tag_spos, &dt->pos);
2699   if (m != MATCH_NO)
2700     return m;
2701   m = match_out_tag (&tag_iomsg, &dt->iomsg);
2702   if (m != MATCH_NO)
2703     return m;
2704   m = match_out_tag (&tag_iostat, &dt->iostat);
2705   if (m != MATCH_NO)
2706     return m;
2707   m = match_ltag (&tag_err, &dt->err);
2708   if (m == MATCH_YES)
2709     dt->err_where = gfc_current_locus;
2710   if (m != MATCH_NO)
2711     return m;
2712   m = match_etag (&tag_advance, &dt->advance);
2713   if (m != MATCH_NO)
2714     return m;
2715   m = match_out_tag (&tag_size, &dt->size);
2716   if (m != MATCH_NO)
2717     return m;
2718
2719   m = match_ltag (&tag_end, &dt->end);
2720   if (m == MATCH_YES)
2721     {
2722       if (k == M_WRITE)
2723        {
2724          gfc_error ("END tag at %C not allowed in output statement");
2725          return MATCH_ERROR;
2726        }
2727       dt->end_where = gfc_current_locus;
2728     }
2729   if (m != MATCH_NO)
2730     return m;
2731
2732   m = match_ltag (&tag_eor, &dt->eor);
2733   if (m == MATCH_YES)
2734     dt->eor_where = gfc_current_locus;
2735   if (m != MATCH_NO)
2736     return m;
2737
2738   return MATCH_NO;
2739 }
2740
2741
2742 /* Free a data transfer structure and everything below it.  */
2743
2744 void
2745 gfc_free_dt (gfc_dt *dt)
2746 {
2747   if (dt == NULL)
2748     return;
2749
2750   gfc_free_expr (dt->io_unit);
2751   gfc_free_expr (dt->format_expr);
2752   gfc_free_expr (dt->rec);
2753   gfc_free_expr (dt->advance);
2754   gfc_free_expr (dt->iomsg);
2755   gfc_free_expr (dt->iostat);
2756   gfc_free_expr (dt->size);
2757   gfc_free_expr (dt->pad);
2758   gfc_free_expr (dt->delim);
2759   gfc_free_expr (dt->sign);
2760   gfc_free_expr (dt->round);
2761   gfc_free_expr (dt->blank);
2762   gfc_free_expr (dt->decimal);
2763   gfc_free_expr (dt->pos);
2764   gfc_free_expr (dt->dt_io_kind);
2765   /* dt->extra_comma is a link to dt_io_kind if it is set.  */
2766   free (dt);
2767 }
2768
2769
2770 /* Resolve everything in a gfc_dt structure.  */
2771
2772 gfc_try
2773 gfc_resolve_dt (gfc_dt *dt, locus *loc)
2774 {
2775   gfc_expr *e;
2776   io_kind k;
2777
2778   /* This is set in any case.  */
2779   gcc_assert (dt->dt_io_kind);
2780   k = dt->dt_io_kind->value.iokind;
2781
2782   RESOLVE_TAG (&tag_format, dt->format_expr);
2783   RESOLVE_TAG (&tag_rec, dt->rec);
2784   RESOLVE_TAG (&tag_spos, dt->pos);
2785   RESOLVE_TAG (&tag_advance, dt->advance);
2786   RESOLVE_TAG (&tag_id, dt->id);
2787   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2788   RESOLVE_TAG (&tag_iostat, dt->iostat);
2789   RESOLVE_TAG (&tag_size, dt->size);
2790   RESOLVE_TAG (&tag_e_pad, dt->pad);
2791   RESOLVE_TAG (&tag_e_delim, dt->delim);
2792   RESOLVE_TAG (&tag_e_sign, dt->sign);
2793   RESOLVE_TAG (&tag_e_round, dt->round);
2794   RESOLVE_TAG (&tag_e_blank, dt->blank);
2795   RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2796   RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2797
2798   e = dt->io_unit;
2799   if (e == NULL)
2800     {
2801       gfc_error ("UNIT not specified at %L", loc);
2802       return FAILURE;
2803     }
2804
2805   if (gfc_resolve_expr (e) == SUCCESS
2806       && (e->ts.type != BT_INTEGER
2807           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2808     {
2809       /* If there is no extra comma signifying the "format" form of the IO
2810          statement, then this must be an error.  */
2811       if (!dt->extra_comma)
2812         {
2813           gfc_error ("UNIT specification at %L must be an INTEGER expression "
2814                      "or a CHARACTER variable", &e->where);
2815           return FAILURE;
2816         }
2817       else
2818         {
2819           /* At this point, we have an extra comma.  If io_unit has arrived as
2820              type character, we assume its really the "format" form of the I/O
2821              statement.  We set the io_unit to the default unit and format to
2822              the character expression.  See F95 Standard section 9.4.  */
2823           if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2824             {
2825               dt->format_expr = dt->io_unit;
2826               dt->io_unit = default_unit (k);
2827
2828               /* Nullify this pointer now so that a warning/error is not
2829                  triggered below for the "Extension".  */
2830               dt->extra_comma = NULL;
2831             }
2832
2833           if (k == M_WRITE)
2834             {
2835               gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2836                          &dt->extra_comma->where);
2837               return FAILURE;
2838             }
2839         }
2840     }
2841
2842   if (e->ts.type == BT_CHARACTER)
2843     {
2844       if (gfc_has_vector_index (e))
2845         {
2846           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2847           return FAILURE;
2848         }
2849
2850       /* If we are writing, make sure the internal unit can be changed.  */
2851       gcc_assert (k != M_PRINT);
2852       if (k == M_WRITE
2853           && gfc_check_vardef_context (e, false, false,
2854                                        _("internal unit in WRITE")) == FAILURE)
2855         return FAILURE;
2856     }
2857
2858   if (e->rank && e->ts.type != BT_CHARACTER)
2859     {
2860       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2861       return FAILURE;
2862     }
2863
2864   if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2865       && mpz_sgn (e->value.integer) < 0)
2866     {
2867       gfc_error ("UNIT number in statement at %L must be non-negative",
2868                  &e->where);
2869       return FAILURE;
2870     }
2871
2872   /* If we are reading and have a namelist, check that all namelist symbols
2873      can appear in a variable definition context.  */
2874   if (k == M_READ && dt->namelist)
2875     {
2876       gfc_namelist* n;
2877       for (n = dt->namelist->namelist; n; n = n->next)
2878         {
2879           gfc_expr* e;
2880           gfc_try t;
2881
2882           e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
2883           t = gfc_check_vardef_context (e, false, false, NULL);
2884           gfc_free_expr (e);
2885
2886           if (t == FAILURE)
2887             {
2888               gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2889                          " the symbol '%s' which may not appear in a"
2890                          " variable definition context",
2891                          dt->namelist->name, loc, n->sym->name);
2892               return FAILURE;
2893             }
2894         }
2895     }
2896
2897   if (dt->extra_comma
2898       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2899                          "item list at %L", &dt->extra_comma->where) == FAILURE)
2900     return FAILURE;
2901
2902   if (dt->err)
2903     {
2904       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2905         return FAILURE;
2906       if (dt->err->defined == ST_LABEL_UNKNOWN)
2907         {
2908           gfc_error ("ERR tag label %d at %L not defined",
2909                       dt->err->value, &dt->err_where);
2910           return FAILURE;
2911         }
2912     }
2913
2914   if (dt->end)
2915     {
2916       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2917         return FAILURE;
2918       if (dt->end->defined == ST_LABEL_UNKNOWN)
2919         {
2920           gfc_error ("END tag label %d at %L not defined",
2921                       dt->end->value, &dt->end_where);
2922           return FAILURE;
2923         }
2924     }
2925
2926   if (dt->eor)
2927     {
2928       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2929         return FAILURE;
2930       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2931         {
2932           gfc_error ("EOR tag label %d at %L not defined",
2933                       dt->eor->value, &dt->eor_where);
2934           return FAILURE;
2935         }
2936     }
2937
2938   /* Check the format label actually exists.  */
2939   if (dt->format_label && dt->format_label != &format_asterisk
2940       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2941     {
2942       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2943                  &dt->format_label->where);
2944       return FAILURE;
2945     }
2946
2947   return SUCCESS;
2948 }
2949
2950
2951 /* Given an io_kind, return its name.  */
2952
2953 static const char *
2954 io_kind_name (io_kind k)
2955 {
2956   const char *name;
2957
2958   switch (k)
2959     {
2960     case M_READ:
2961       name = "READ";
2962       break;
2963     case M_WRITE:
2964       name = "WRITE";
2965       break;
2966     case M_PRINT:
2967       name = "PRINT";
2968       break;
2969     case M_INQUIRE:
2970       name = "INQUIRE";
2971       break;
2972     default:
2973       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2974     }
2975
2976   return name;
2977 }
2978
2979
2980 /* Match an IO iteration statement of the form:
2981
2982    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2983
2984    which is equivalent to a single IO element.  This function is
2985    mutually recursive with match_io_element().  */
2986
2987 static match match_io_element (io_kind, gfc_code **);
2988
2989 static match
2990 match_io_iterator (io_kind k, gfc_code **result)
2991 {
2992   gfc_code *head, *tail, *new_code;
2993   gfc_iterator *iter;
2994   locus old_loc;
2995   match m;
2996   int n;
2997
2998   iter = NULL;
2999   head = NULL;
3000   old_loc = gfc_current_locus;
3001
3002   if (gfc_match_char ('(') != MATCH_YES)
3003     return MATCH_NO;
3004
3005   m = match_io_element (k, &head);
3006   tail = head;
3007
3008   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3009     {
3010       m = MATCH_NO;
3011       goto cleanup;
3012     }
3013
3014   /* Can't be anything but an IO iterator.  Build a list.  */
3015   iter = gfc_get_iterator ();
3016
3017   for (n = 1;; n++)
3018     {
3019       m = gfc_match_iterator (iter, 0);
3020       if (m == MATCH_ERROR)
3021         goto cleanup;
3022       if (m == MATCH_YES)
3023         {
3024           gfc_check_do_variable (iter->var->symtree);
3025           break;
3026         }
3027
3028       m = match_io_element (k, &new_code);
3029       if (m == MATCH_ERROR)
3030         goto cleanup;
3031       if (m == MATCH_NO)
3032         {
3033           if (n > 2)
3034             goto syntax;
3035           goto cleanup;
3036         }
3037
3038       tail = gfc_append_code (tail, new_code);
3039
3040       if (gfc_match_char (',') != MATCH_YES)
3041         {
3042           if (n > 2)
3043             goto syntax;
3044           m = MATCH_NO;
3045           goto cleanup;
3046         }
3047     }
3048
3049   if (gfc_match_char (')') != MATCH_YES)
3050     goto syntax;
3051
3052   new_code = gfc_get_code ();
3053   new_code->op = EXEC_DO;
3054   new_code->ext.iterator = iter;
3055
3056   new_code->block = gfc_get_code ();
3057   new_code->block->op = EXEC_DO;
3058   new_code->block->next = head;
3059
3060   *result = new_code;
3061   return MATCH_YES;
3062
3063 syntax:
3064   gfc_error ("Syntax error in I/O iterator at %C");
3065   m = MATCH_ERROR;
3066
3067 cleanup:
3068   gfc_free_iterator (iter, 1);
3069   gfc_free_statements (head);
3070   gfc_current_locus = old_loc;
3071   return m;
3072 }
3073
3074
3075 /* Match a single element of an IO list, which is either a single
3076    expression or an IO Iterator.  */
3077
3078 static match
3079 match_io_element (io_kind k, gfc_code **cpp)
3080 {
3081   gfc_expr *expr;
3082   gfc_code *cp;
3083   match m;
3084
3085   expr = NULL;
3086
3087   m = match_io_iterator (k, cpp);
3088   if (m == MATCH_YES)
3089     return MATCH_YES;
3090
3091   if (k == M_READ)
3092     {
3093       m = gfc_match_variable (&expr, 0);
3094       if (m == MATCH_NO)
3095         gfc_error ("Expected variable in READ statement at %C");
3096     }
3097   else
3098     {
3099       m = gfc_match_expr (&expr);
3100       if (m == MATCH_NO)
3101         gfc_error ("Expected expression in %s statement at %C",
3102                    io_kind_name (k));
3103     }
3104
3105   if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3106     m = MATCH_ERROR;
3107
3108   if (m != MATCH_YES)
3109     {
3110       gfc_free_expr (expr);
3111       return MATCH_ERROR;
3112     }
3113
3114   cp = gfc_get_code ();
3115   cp->op = EXEC_TRANSFER;
3116   cp->expr1 = expr;
3117   if (k != M_INQUIRE)
3118     cp->ext.dt = current_dt;
3119
3120   *cpp = cp;
3121   return MATCH_YES;
3122 }
3123
3124
3125 /* Match an I/O list, building gfc_code structures as we go.  */
3126
3127 static match
3128 match_io_list (io_kind k, gfc_code **head_p)
3129 {
3130   gfc_code *head, *tail, *new_code;
3131   match m;
3132
3133   *head_p = head = tail = NULL;
3134   if (gfc_match_eos () == MATCH_YES)
3135     return MATCH_YES;
3136
3137   for (;;)
3138     {
3139       m = match_io_element (k, &new_code);
3140       if (m == MATCH_ERROR)
3141         goto cleanup;
3142       if (m == MATCH_NO)
3143         goto syntax;
3144
3145       tail = gfc_append_code (tail, new_code);
3146       if (head == NULL)
3147         head = new_code;
3148
3149       if (gfc_match_eos () == MATCH_YES)
3150         break;
3151       if (gfc_match_char (',') != MATCH_YES)
3152         goto syntax;
3153     }
3154
3155   *head_p = head;
3156   return MATCH_YES;
3157
3158 syntax:
3159   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3160
3161 cleanup:
3162   gfc_free_statements (head);
3163   return MATCH_ERROR;
3164 }
3165
3166
3167 /* Attach the data transfer end node.  */
3168
3169 static void
3170 terminate_io (gfc_code *io_code)
3171 {
3172   gfc_code *c;
3173
3174   if (io_code == NULL)
3175     io_code = new_st.block;
3176
3177   c = gfc_get_code ();
3178   c->op = EXEC_DT_END;
3179
3180   /* Point to structure that is already there */
3181   c->ext.dt = new_st.ext.dt;
3182   gfc_append_code (io_code, c);
3183 }
3184
3185
3186 /* Check the constraints for a data transfer statement.  The majority of the
3187    constraints appearing in 9.4 of the standard appear here.  Some are handled
3188    in resolve_tag and others in gfc_resolve_dt.  */
3189
3190 static match
3191 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3192                       locus *spec_end)
3193 {
3194 #define io_constraint(condition,msg,arg)\
3195 if (condition) \
3196   {\
3197     gfc_error(msg,arg);\
3198     m = MATCH_ERROR;\
3199   }
3200
3201   match m;
3202   gfc_expr *expr;
3203   gfc_symbol *sym = NULL;
3204   bool warn, unformatted;
3205
3206   warn = (dt->err || dt->iostat) ? true : false;
3207   unformatted = dt->format_expr == NULL && dt->format_label == NULL
3208                 && dt->namelist == NULL;
3209
3210   m = MATCH_YES;
3211
3212   expr = dt->io_unit;
3213   if (expr && expr->expr_type == EXPR_VARIABLE
3214       && expr->ts.type == BT_CHARACTER)
3215     {
3216       sym = expr->symtree->n.sym;
3217
3218       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3219                      "Internal file at %L must not be INTENT(IN)",
3220                      &expr->where);
3221
3222       io_constraint (gfc_has_vector_index (dt->io_unit),
3223                      "Internal file incompatible with vector subscript at %L",
3224                      &expr->where);
3225
3226       io_constraint (dt->rec != NULL,
3227                      "REC tag at %L is incompatible with internal file",
3228                      &dt->rec->where);
3229
3230       io_constraint (dt->pos != NULL,
3231                      "POS tag at %L is incompatible with internal file",
3232                      &dt->pos->where);
3233
3234       io_constraint (unformatted,
3235                      "Unformatted I/O not allowed with internal unit at %L",
3236                      &dt->io_unit->where);
3237
3238       io_constraint (dt->asynchronous != NULL,
3239                      "ASYNCHRONOUS tag at %L not allowed with internal file",
3240                      &dt->asynchronous->where);
3241
3242       if (dt->namelist != NULL)
3243         {
3244           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
3245                               "at %L with namelist", &expr->where)
3246               == FAILURE)
3247             m = MATCH_ERROR;
3248         }
3249
3250       io_constraint (dt->advance != NULL,
3251                      "ADVANCE tag at %L is incompatible with internal file",
3252                      &dt->advance->where);
3253     }
3254
3255   if (expr && expr->ts.type != BT_CHARACTER)
3256     {
3257
3258       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3259                      "IO UNIT in %s statement at %C must be "
3260                      "an internal file in a PURE procedure",
3261                      io_kind_name (k));
3262
3263       if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
3264         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3265
3266     }
3267
3268   if (k != M_READ)
3269     {
3270       io_constraint (dt->end, "END tag not allowed with output at %L",
3271                      &dt->end_where);
3272
3273       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3274                      &dt->eor_where);
3275
3276       io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3277                      &dt->blank->where);
3278
3279       io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3280                      &dt->pad->where);
3281
3282       io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3283                      &dt->size->where);
3284     }
3285   else
3286     {
3287       io_constraint (dt->size && dt->advance == NULL,
3288                      "SIZE tag at %L requires an ADVANCE tag",
3289                      &dt->size->where);
3290
3291       io_constraint (dt->eor && dt->advance == NULL,
3292                      "EOR tag at %L requires an ADVANCE tag",
3293                      &dt->eor_where);
3294     }
3295
3296   if (dt->asynchronous)
3297     {
3298       static const char * asynchronous[] = { "YES", "NO", NULL };
3299
3300       if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3301         {
3302           gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3303                      "expression", &dt->asynchronous->where);
3304           return MATCH_ERROR;
3305         }
3306
3307       if (!compare_to_allowed_values
3308                 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3309                  dt->asynchronous->value.character.string,
3310                  io_kind_name (k), warn))
3311         return MATCH_ERROR;
3312     }
3313
3314   if (dt->id)
3315     {
3316       bool not_yes
3317         = !dt->asynchronous
3318           || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3319           || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3320                                    "yes", 3) != 0;
3321       io_constraint (not_yes,
3322                      "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3323                      "specifier", &dt->id->where);
3324     }
3325
3326   if (dt->decimal)
3327     {
3328       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3329           "not allowed in Fortran 95") == FAILURE)
3330         return MATCH_ERROR;
3331
3332       if (dt->decimal->expr_type == EXPR_CONSTANT)
3333         {
3334           static const char * decimal[] = { "COMMA", "POINT", NULL };
3335
3336           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3337                                           dt->decimal->value.character.string,
3338                                           io_kind_name (k), warn))
3339             return MATCH_ERROR;
3340
3341           io_constraint (unformatted,
3342                          "the DECIMAL= specifier at %L must be with an "
3343                          "explicit format expression", &dt->decimal->where);
3344         }
3345     }
3346
3347   if (dt->blank)
3348     {
3349       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3350           "not allowed in Fortran 95") == FAILURE)
3351         return MATCH_ERROR;
3352
3353       if (dt->blank->expr_type == EXPR_CONSTANT)
3354         {
3355           static const char * blank[] = { "NULL", "ZERO", NULL };
3356
3357           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3358                                           dt->blank->value.character.string,
3359                                           io_kind_name (k), warn))
3360             return MATCH_ERROR;
3361
3362           io_constraint (unformatted,
3363                          "the BLANK= specifier at %L must be with an "
3364                          "explicit format expression", &dt->blank->where);
3365         }
3366     }
3367
3368   if (dt->pad)
3369     {
3370       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3371           "not allowed in Fortran 95") == FAILURE)
3372         return MATCH_ERROR;
3373
3374       if (dt->pad->expr_type == EXPR_CONSTANT)
3375         {
3376           static const char * pad[] = { "YES", "NO", NULL };
3377
3378           if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3379                                           dt->pad->value.character.string,
3380                                           io_kind_name (k), warn))
3381             return MATCH_ERROR;
3382
3383           io_constraint (unformatted,
3384                          "the PAD= specifier at %L must be with an "
3385                          "explicit format expression", &dt->pad->where);
3386         }
3387     }
3388
3389   if (dt->round)
3390     {
3391       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3392           "not allowed in Fortran 95") == FAILURE)
3393         return MATCH_ERROR;
3394
3395       if (dt->round->expr_type == EXPR_CONSTANT)
3396         {
3397           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3398                                           "COMPATIBLE", "PROCESSOR_DEFINED",
3399                                           NULL };
3400
3401           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3402                                           dt->round->value.character.string,
3403                                           io_kind_name (k), warn))
3404             return MATCH_ERROR;
3405         }
3406     }
3407
3408   if (dt->sign)
3409     {
3410       /* When implemented, change the following to use gfc_notify_std F2003.
3411       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3412           "not allowed in Fortran 95") == FAILURE)
3413         return MATCH_ERROR;  */
3414       if (dt->sign->expr_type == EXPR_CONSTANT)
3415         {
3416           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3417                                          NULL };
3418
3419           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3420                                       dt->sign->value.character.string,
3421                                       io_kind_name (k), warn))
3422             return MATCH_ERROR;
3423
3424           io_constraint (unformatted,
3425                          "SIGN= specifier at %L must be with an "
3426                          "explicit format expression", &dt->sign->where);
3427
3428           io_constraint (k == M_READ,
3429                          "SIGN= specifier at %L not allowed in a "
3430                          "READ statement", &dt->sign->where);
3431         }
3432     }
3433
3434   if (dt->delim)
3435     {
3436       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3437           "not allowed in Fortran 95") == FAILURE)
3438         return MATCH_ERROR;
3439
3440       if (dt->delim->expr_type == EXPR_CONSTANT)
3441         {
3442           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3443
3444           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3445                                           dt->delim->value.character.string,
3446                                           io_kind_name (k), warn))
3447             return MATCH_ERROR;
3448
3449           io_constraint (k == M_READ,
3450                          "DELIM= specifier at %L not allowed in a "
3451                          "READ statement", &dt->delim->where);
3452
3453           io_constraint (dt->format_label != &format_asterisk
3454                          && dt->namelist == NULL,
3455                          "DELIM= specifier at %L must have FMT=*",
3456                          &dt->delim->where);
3457
3458           io_constraint (unformatted && dt->namelist == NULL,
3459                          "DELIM= specifier at %L must be with FMT=* or "
3460                          "NML= specifier ", &dt->delim->where);
3461         }
3462     }
3463
3464   if (dt->namelist)
3465     {
3466       io_constraint (io_code && dt->namelist,
3467                      "NAMELIST cannot be followed by IO-list at %L",
3468                      &io_code->loc);
3469
3470       io_constraint (dt->format_expr,
3471                      "IO spec-list cannot contain both NAMELIST group name "
3472                      "and format specification at %L",
3473                      &dt->format_expr->where);
3474
3475       io_constraint (dt->format_label,
3476                      "IO spec-list cannot contain both NAMELIST group name "
3477                      "and format label at %L", spec_end);
3478
3479       io_constraint (dt->rec,
3480                      "NAMELIST IO is not allowed with a REC= specifier "
3481                      "at %L", &dt->rec->where);
3482
3483       io_constraint (dt->advance,
3484                      "NAMELIST IO is not allowed with a ADVANCE= specifier "
3485                      "at %L", &dt->advance->where);
3486     }
3487
3488   if (dt->rec)
3489     {
3490       io_constraint (dt->end,
3491                      "An END tag is not allowed with a "
3492                      "REC= specifier at %L", &dt->end_where);
3493
3494       io_constraint (dt->format_label == &format_asterisk,
3495                      "FMT=* is not allowed with a REC= specifier "
3496                      "at %L", spec_end);
3497
3498       io_constraint (dt->pos,
3499                      "POS= is not allowed with REC= specifier "
3500                      "at %L", &dt->pos->where);
3501     }
3502
3503   if (dt->advance)
3504     {
3505       int not_yes, not_no;
3506       expr = dt->advance;
3507
3508       io_constraint (dt->format_label == &format_asterisk,
3509                      "List directed format(*) is not allowed with a "
3510                      "ADVANCE= specifier at %L.", &expr->where);
3511
3512       io_constraint (unformatted,
3513                      "the ADVANCE= specifier at %L must appear with an "
3514                      "explicit format expression", &expr->where);
3515
3516       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3517         {
3518           const gfc_char_t *advance = expr->value.character.string;
3519           not_no = gfc_wide_strlen (advance) != 2
3520                    || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3521           not_yes = gfc_wide_strlen (advance) != 3
3522                     || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3523         }
3524       else
3525         {
3526           not_no = 0;
3527           not_yes = 0;
3528         }
3529
3530       io_constraint (not_no && not_yes,
3531                      "ADVANCE= specifier at %L must have value = "
3532                      "YES or NO.", &expr->where);
3533
3534       io_constraint (dt->size && not_no && k == M_READ,
3535                      "SIZE tag at %L requires an ADVANCE = 'NO'",
3536                      &dt->size->where);
3537
3538       io_constraint (dt->eor && not_no && k == M_READ,
3539                      "EOR tag at %L requires an ADVANCE = 'NO'",
3540                      &dt->eor_where);
3541     }
3542
3543   expr = dt->format_expr;
3544   if (gfc_simplify_expr (expr, 0) == FAILURE
3545       || check_format_string (expr, k == M_READ) == FAILURE)
3546     return MATCH_ERROR;
3547
3548   return m;
3549 }
3550 #undef io_constraint
3551
3552
3553 /* Match a READ, WRITE or PRINT statement.  */
3554
3555 static match
3556 match_io (io_kind k)
3557 {
3558   char name[GFC_MAX_SYMBOL_LEN + 1];
3559   gfc_code *io_code;
3560   gfc_symbol *sym;
3561   int comma_flag;
3562   locus where;
3563   locus spec_end;
3564   gfc_dt *dt;
3565   match m;
3566
3567   where = gfc_current_locus;
3568   comma_flag = 0;
3569   current_dt = dt = XCNEW (gfc_dt);
3570   m = gfc_match_char ('(');
3571   if (m == MATCH_NO)
3572     {
3573       where = gfc_current_locus;
3574       if (k == M_WRITE)
3575         goto syntax;
3576       else if (k == M_PRINT)
3577         {
3578           /* Treat the non-standard case of PRINT namelist.  */
3579           if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3580               && gfc_match_name (name) == MATCH_YES)
3581             {
3582               gfc_find_symbol (name, NULL, 1, &sym);
3583               if (sym && sym->attr.flavor == FL_NAMELIST)
3584                 {
3585                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3586                                       "%C is an extension") == FAILURE)
3587                     {
3588                       m = MATCH_ERROR;
3589                       goto cleanup;
3590                     }
3591
3592                   dt->io_unit = default_unit (k);
3593                   dt->namelist = sym;
3594                   goto get_io_list;
3595                 }
3596               else
3597                 gfc_current_locus = where;
3598             }
3599         }
3600
3601       if (gfc_current_form == FORM_FREE)
3602         {
3603           char c = gfc_peek_ascii_char ();
3604           if (c != ' ' && c != '*' && c != '\'' && c != '"')
3605             {
3606               m = MATCH_NO;
3607               goto cleanup;
3608             }
3609         }
3610
3611       m = match_dt_format (dt);
3612       if (m == MATCH_ERROR)
3613         goto cleanup;
3614       if (m == MATCH_NO)
3615         goto syntax;
3616
3617       comma_flag = 1;
3618       dt->io_unit = default_unit (k);
3619       goto get_io_list;
3620     }
3621   else
3622     {
3623       /* Before issuing an error for a malformed 'print (1,*)' type of
3624          error, check for a default-char-expr of the form ('(I0)').  */
3625       if (k == M_PRINT && m == MATCH_YES)
3626         {
3627           /* Reset current locus to get the initial '(' in an expression.  */
3628           gfc_current_locus = where;
3629           dt->format_expr = NULL;
3630           m = match_dt_format (dt);
3631
3632           if (m == MATCH_ERROR)
3633             goto cleanup;
3634           if (m == MATCH_NO || dt->format_expr == NULL)
3635             goto syntax;
3636
3637           comma_flag = 1;
3638           dt->io_unit = default_unit (k);
3639           goto get_io_list;
3640         }
3641     }
3642
3643   /* Match a control list */
3644   if (match_dt_element (k, dt) == MATCH_YES)
3645     goto next;
3646   if (match_dt_unit (k, dt) != MATCH_YES)
3647     goto loop;
3648
3649   if (gfc_match_char (')') == MATCH_YES)
3650     goto get_io_list;
3651   if (gfc_match_char (',') != MATCH_YES)
3652     goto syntax;
3653
3654   m = match_dt_element (k, dt);
3655   if (m == MATCH_YES)
3656     goto next;
3657   if (m == MATCH_ERROR)
3658     goto cleanup;
3659
3660   m = match_dt_format (dt);
3661   if (m == MATCH_YES)
3662     goto next;
3663   if (m == MATCH_ERROR)
3664     goto cleanup;
3665
3666   where = gfc_current_locus;
3667
3668   m = gfc_match_name (name);
3669   if (m == MATCH_YES)
3670     {
3671       gfc_find_symbol (name, NULL, 1, &sym);
3672       if (sym && sym->attr.flavor == FL_NAMELIST)
3673         {
3674           dt->namelist = sym;
3675           if (k == M_READ && check_namelist (sym))
3676             {
3677               m = MATCH_ERROR;
3678               goto cleanup;
3679             }
3680           goto next;
3681         }
3682     }
3683
3684   gfc_current_locus = where;
3685
3686   goto loop;                    /* No matches, try regular elements */
3687
3688 next:
3689   if (gfc_match_char (')') == MATCH_YES)
3690     goto get_io_list;
3691   if (gfc_match_char (',') != MATCH_YES)
3692     goto syntax;
3693
3694 loop:
3695   for (;;)
3696     {
3697       m = match_dt_element (k, dt);
3698       if (m == MATCH_NO)
3699         goto syntax;
3700       if (m == MATCH_ERROR)
3701         goto cleanup;
3702
3703       if (gfc_match_char (')') == MATCH_YES)
3704         break;
3705       if (gfc_match_char (',') != MATCH_YES)
3706         goto syntax;
3707     }
3708
3709 get_io_list:
3710
3711   /* Used in check_io_constraints, where no locus is available.  */
3712   spec_end = gfc_current_locus;
3713
3714   /* Save the IO kind for later use.  */
3715   dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
3716
3717   /* Optional leading comma (non-standard).  We use a gfc_expr structure here
3718      to save the locus.  This is used later when resolving transfer statements
3719      that might have a format expression without unit number.  */
3720   if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3721     dt->extra_comma = dt->dt_io_kind;
3722
3723   io_code = NULL;
3724   if (gfc_match_eos () != MATCH_YES)
3725     {
3726       if (comma_flag && gfc_match_char (',') != MATCH_YES)
3727         {
3728           gfc_error ("Expected comma in I/O list at %C");
3729           m = MATCH_ERROR;
3730           goto cleanup;
3731         }
3732
3733       m = match_io_list (k, &io_code);
3734       if (m == MATCH_ERROR)
3735         goto cleanup;
3736       if (m == MATCH_NO)
3737         goto syntax;
3738     }
3739
3740   /* A full IO statement has been matched.  Check the constraints.  spec_end is
3741      supplied for cases where no locus is supplied.  */
3742   m = check_io_constraints (k, dt, io_code, &spec_end);
3743
3744   if (m == MATCH_ERROR)
3745     goto cleanup;
3746
3747   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3748   new_st.ext.dt = dt;
3749   new_st.block = gfc_get_code ();
3750   new_st.block->op = new_st.op;
3751   new_st.block->next = io_code;
3752
3753   terminate_io (io_code);
3754
3755   return MATCH_YES;
3756
3757 syntax:
3758   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3759   m = MATCH_ERROR;
3760
3761 cleanup:
3762   gfc_free_dt (dt);
3763   return m;
3764 }
3765
3766
3767 match
3768 gfc_match_read (void)
3769 {
3770   return match_io (M_READ);
3771 }
3772
3773
3774 match
3775 gfc_match_write (void)
3776 {
3777   return match_io (M_WRITE);
3778 }
3779
3780
3781 match
3782 gfc_match_print (void)
3783 {
3784   match m;
3785
3786   m = match_io (M_PRINT);
3787   if (m != MATCH_YES)
3788     return m;
3789
3790   if (gfc_pure (NULL))
3791     {
3792       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3793       return MATCH_ERROR;
3794     }
3795
3796   if (gfc_implicit_pure (NULL))
3797     gfc_current_ns->proc_name->attr.implicit_pure = 0;
3798
3799   return MATCH_YES;
3800 }
3801
3802
3803 /* Free a gfc_inquire structure.  */
3804
3805 void
3806 gfc_free_inquire (gfc_inquire *inquire)
3807 {
3808
3809   if (inquire == NULL)
3810     return;
3811
3812   gfc_free_expr (inquire->unit);
3813   gfc_free_expr (inquire->file);
3814   gfc_free_expr (inquire->iomsg);
3815   gfc_free_expr (inquire->iostat);
3816   gfc_free_expr (inquire->exist);
3817   gfc_free_expr (inquire->opened);
3818   gfc_free_expr (inquire->number);
3819   gfc_free_expr (inquire->named);
3820   gfc_free_expr (inquire->name);
3821   gfc_free_expr (inquire->access);
3822   gfc_free_expr (inquire->sequential);
3823   gfc_free_expr (inquire->direct);
3824   gfc_free_expr (inquire->form);
3825   gfc_free_expr (inquire->formatted);
3826   gfc_free_expr (inquire->unformatted);
3827   gfc_free_expr (inquire->recl);
3828   gfc_free_expr (inquire->nextrec);
3829   gfc_free_expr (inquire->blank);
3830   gfc_free_expr (inquire->position);
3831   gfc_free_expr (inquire->action);
3832   gfc_free_expr (inquire->read);
3833   gfc_free_expr (inquire->write);
3834   gfc_free_expr (inquire->readwrite);
3835   gfc_free_expr (inquire->delim);
3836   gfc_free_expr (inquire->encoding);
3837   gfc_free_expr (inquire->pad);
3838   gfc_free_expr (inquire->iolength);
3839   gfc_free_expr (inquire->convert);
3840   gfc_free_expr (inquire->strm_pos);
3841   gfc_free_expr (inquire->asynchronous);
3842   gfc_free_expr (inquire->decimal);
3843   gfc_free_expr (inquire->pending);
3844   gfc_free_expr (inquire->id);
3845   gfc_free_expr (inquire->sign);
3846   gfc_free_expr (inquire->size);
3847   gfc_free_expr (inquire->round);
3848   free (inquire);
3849 }
3850
3851
3852 /* Match an element of an INQUIRE statement.  */
3853
3854 #define RETM   if (m != MATCH_NO) return m;
3855
3856 static match
3857 match_inquire_element (gfc_inquire *inquire)
3858 {
3859   match m;
3860
3861   m = match_etag (&tag_unit, &inquire->unit);
3862   RETM m = match_etag (&tag_file, &inquire->file);
3863   RETM m = match_ltag (&tag_err, &inquire->err);
3864   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3865   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3866   RETM m = match_vtag (&tag_exist, &inquire->exist);
3867   RETM m = match_vtag (&tag_opened, &inquire->opened);
3868   RETM m = match_vtag (&tag_named, &inquire->named);
3869   RETM m = match_vtag (&tag_name, &inquire->name);
3870   RETM m = match_out_tag (&tag_number, &inquire->number);
3871   RETM m = match_vtag (&tag_s_access, &inquire->access);
3872   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3873   RETM m = match_vtag (&tag_direct, &inquire->direct);
3874   RETM m = match_vtag (&tag_s_form, &inquire->form);
3875   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3876   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3877   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3878   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3879   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3880   RETM m = match_vtag (&tag_s_position, &inquire->position);
3881   RETM m = match_vtag (&tag_s_action, &inquire->action);
3882   RETM m = match_vtag (&tag_read, &inquire->read);
3883   RETM m = match_vtag (&tag_write, &inquire->write);
3884   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3885   RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3886   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3887   RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3888   RETM m = match_vtag (&tag_size, &inquire->size);
3889   RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3890   RETM m = match_vtag (&tag_s_round, &inquire->round);
3891   RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3892   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3893   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3894   RETM m = match_vtag (&tag_convert, &inquire->convert);
3895   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3896   RETM m = match_vtag (&tag_pending, &inquire->pending);
3897   RETM m = match_vtag (&tag_id, &inquire->id);
3898   RETM return MATCH_NO;
3899 }
3900
3901 #undef RETM
3902
3903
3904 match
3905 gfc_match_inquire (void)
3906 {
3907   gfc_inquire *inquire;
3908   gfc_code *code;
3909   match m;
3910   locus loc;
3911
3912   m = gfc_match_char ('(');
3913   if (m == MATCH_NO)
3914     return m;
3915
3916   inquire = XCNEW (gfc_inquire);
3917
3918   loc = gfc_current_locus;
3919
3920   m = match_inquire_element (inquire);
3921   if (m == MATCH_ERROR)
3922     goto cleanup;
3923   if (m == MATCH_NO)
3924     {
3925       m = gfc_match_expr (&inquire->unit);
3926       if (m == MATCH_ERROR)
3927         goto cleanup;
3928       if (m == MATCH_NO)
3929         goto syntax;
3930     }
3931
3932   /* See if we have the IOLENGTH form of the inquire statement.  */
3933   if (inquire->iolength != NULL)
3934     {
3935       if (gfc_match_char (')') != MATCH_YES)
3936         goto syntax;
3937
3938       m = match_io_list (M_INQUIRE, &code);
3939       if (m == MATCH_ERROR)
3940         goto cleanup;
3941       if (m == MATCH_NO)
3942         goto syntax;
3943
3944       new_st.op = EXEC_IOLENGTH;
3945       new_st.expr1 = inquire->iolength;
3946       new_st.ext.inquire = inquire;
3947
3948       if (gfc_pure (NULL))
3949         {
3950           gfc_free_statements (code);
3951           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3952           return MATCH_ERROR;
3953         }
3954
3955       if (gfc_implicit_pure (NULL))
3956         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3957
3958       new_st.block = gfc_get_code ();
3959       new_st.block->op = EXEC_IOLENGTH;
3960       terminate_io (code);
3961       new_st.block->next = code;
3962       return MATCH_YES;
3963     }
3964
3965   /* At this point, we have the non-IOLENGTH inquire statement.  */
3966   for (;;)
3967     {
3968       if (gfc_match_char (')') == MATCH_YES)
3969         break;
3970       if (gfc_match_char (',') != MATCH_YES)
3971         goto syntax;
3972
3973       m = match_inquire_element (inquire);
3974       if (m == MATCH_ERROR)
3975         goto cleanup;
3976       if (m == MATCH_NO)
3977         goto syntax;
3978
3979       if (inquire->iolength != NULL)
3980         {
3981           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3982           goto cleanup;
3983         }
3984     }
3985
3986   if (gfc_match_eos () != MATCH_YES)
3987     goto syntax;
3988
3989   if (inquire->unit != NULL && inquire->file != NULL)
3990     {
3991       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3992                  "UNIT specifiers", &loc);
3993       goto cleanup;
3994     }
3995
3996   if (inquire->unit == NULL && inquire->file == NULL)
3997     {
3998       gfc_error ("INQUIRE statement at %L requires either FILE or "
3999                  "UNIT specifier", &loc);
4000       goto cleanup;
4001     }
4002
4003   if (gfc_pure (NULL))
4004     {
4005       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4006       goto cleanup;
4007     }
4008
4009   if (gfc_implicit_pure (NULL))
4010     gfc_current_ns->proc_name->attr.implicit_pure = 0;
4011
4012   if (inquire->id != NULL && inquire->pending == NULL)
4013     {
4014       gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4015                  "the ID= specifier", &loc);
4016       goto cleanup;
4017     }
4018
4019   new_st.op = EXEC_INQUIRE;
4020   new_st.ext.inquire = inquire;
4021   return MATCH_YES;
4022
4023 syntax:
4024   gfc_syntax_error (ST_INQUIRE);
4025
4026 cleanup:
4027   gfc_free_inquire (inquire);
4028   return MATCH_ERROR;
4029 }
4030
4031
4032 /* Resolve everything in a gfc_inquire structure.  */
4033
4034 gfc_try
4035 gfc_resolve_inquire (gfc_inquire *inquire)
4036 {
4037   RESOLVE_TAG (&tag_unit, inquire->unit);
4038   RESOLVE_TAG (&tag_file, inquire->file);
4039   RESOLVE_TAG (&tag_id, inquire->id);
4040
4041   /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4042      contexts.  Thus, use an extended RESOLVE_TAG macro for that.  */
4043 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4044   RESOLVE_TAG (tag, expr); \
4045   if (expr) \
4046     { \
4047       char context[64]; \
4048       sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4049       if (gfc_check_vardef_context ((expr), false, false, context) == FAILURE) \
4050         return FAILURE; \
4051     }
4052   INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4053   INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4054   INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4055   INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4056   INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4057   INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4058   INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4059   INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4060   INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4061   INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4062   INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4063   INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4064   INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4065   INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4066   INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4067   INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4068   INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4069   INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4070   INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4071   INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4072   INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4073   INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4074   INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4075   INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4076   INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4077   INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4078   INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4079   INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4080   INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4081   INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4082   INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4083   INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4084   INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4085   INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4086 #undef INQUIRE_RESOLVE_TAG
4087
4088   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
4089     return FAILURE;
4090
4091   return SUCCESS;
4092 }
4093
4094
4095 void
4096 gfc_free_wait (gfc_wait *wait)
4097 {
4098   if (wait == NULL)
4099     return;
4100
4101   gfc_free_expr (wait->unit);
4102   gfc_free_expr (wait->iostat);
4103   gfc_free_expr (wait->iomsg);
4104   gfc_free_expr (wait->id);
4105 }
4106
4107
4108 gfc_try
4109 gfc_resolve_wait (gfc_wait *wait)
4110 {
4111   RESOLVE_TAG (&tag_unit, wait->unit);
4112   RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4113   RESOLVE_TAG (&tag_iostat, wait->iostat);
4114   RESOLVE_TAG (&tag_id, wait->id);
4115
4116   if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
4117     return FAILURE;
4118
4119   if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
4120     return FAILURE;
4121
4122   return SUCCESS;
4123 }
4124
4125 /* Match an element of a WAIT statement.  */
4126
4127 #define RETM   if (m != MATCH_NO) return m;
4128
4129 static match
4130 match_wait_element (gfc_wait *wait)
4131 {
4132   match m;
4133
4134   m = match_etag (&tag_unit, &wait->unit);
4135   RETM m = match_ltag (&tag_err, &wait->err);
4136   RETM m = match_ltag (&tag_end, &wait->eor);
4137   RETM m = match_ltag (&tag_eor, &wait->end);
4138   RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4139   RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4140   RETM m = match_etag (&tag_id, &wait->id);
4141   RETM return MATCH_NO;
4142 }
4143
4144 #undef RETM
4145
4146
4147 match
4148 gfc_match_wait (void)
4149 {
4150   gfc_wait *wait;
4151   match m;
4152
4153   m = gfc_match_char ('(');
4154   if (m == MATCH_NO)
4155     return m;
4156
4157   wait = XCNEW (gfc_wait);
4158
4159   m = match_wait_element (wait);
4160   if (m == MATCH_ERROR)
4161     goto cleanup;
4162   if (m == MATCH_NO)
4163     {
4164       m = gfc_match_expr (&wait->unit);
4165       if (m == MATCH_ERROR)
4166         goto cleanup;
4167       if (m == MATCH_NO)
4168         goto syntax;
4169     }
4170
4171   for (;;)
4172     {
4173       if (gfc_match_char (')') == MATCH_YES)
4174         break;
4175       if (gfc_match_char (',') != MATCH_YES)
4176         goto syntax;
4177
4178       m = match_wait_element (wait);
4179       if (m == MATCH_ERROR)
4180         goto cleanup;
4181       if (m == MATCH_NO)
4182         goto syntax;
4183     }
4184
4185   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
4186           "not allowed in Fortran 95") == FAILURE)
4187     goto cleanup;
4188
4189   if (gfc_pure (NULL))
4190     {
4191       gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4192       goto cleanup;
4193     }
4194
4195   if (gfc_implicit_pure (NULL))
4196     gfc_current_ns->proc_name->attr.implicit_pure = 0;
4197
4198   new_st.op = EXEC_WAIT;
4199   new_st.ext.wait = wait;
4200
4201   return MATCH_YES;
4202
4203 syntax:
4204   gfc_syntax_error (ST_WAIT);
4205
4206 cleanup:
4207   gfc_free_wait (wait);
4208   return MATCH_ERROR;
4209 }