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