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