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