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