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