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