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->pos);
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_expr (dt->pos);
2482   gfc_free (dt);
2483 }
2484
2485
2486 /* Resolve everything in a gfc_dt structure.  */
2487
2488 gfc_try
2489 gfc_resolve_dt (gfc_dt *dt)
2490 {
2491   gfc_expr *e;
2492
2493   RESOLVE_TAG (&tag_format, dt->format_expr);
2494   RESOLVE_TAG (&tag_rec, dt->rec);
2495   RESOLVE_TAG (&tag_spos, dt->pos);
2496   RESOLVE_TAG (&tag_advance, dt->advance);
2497   RESOLVE_TAG (&tag_id, dt->id);
2498   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2499   RESOLVE_TAG (&tag_iostat, dt->iostat);
2500   RESOLVE_TAG (&tag_size, dt->size);
2501   RESOLVE_TAG (&tag_e_pad, dt->pad);
2502   RESOLVE_TAG (&tag_e_delim, dt->delim);
2503   RESOLVE_TAG (&tag_e_sign, dt->sign);
2504   RESOLVE_TAG (&tag_e_round, dt->round);
2505   RESOLVE_TAG (&tag_e_blank, dt->blank);
2506   RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2507   RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2508
2509   e = dt->io_unit;
2510   if (gfc_resolve_expr (e) == SUCCESS
2511       && (e->ts.type != BT_INTEGER
2512           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2513     {
2514       /* If there is no extra comma signifying the "format" form of the IO
2515          statement, then this must be an error.  */
2516       if (!dt->extra_comma)
2517         {
2518           gfc_error ("UNIT specification at %L must be an INTEGER expression "
2519                      "or a CHARACTER variable", &e->where);
2520           return FAILURE;
2521         }
2522       else
2523         {
2524           /* At this point, we have an extra comma.  If io_unit has arrived as
2525              type character, we assume its really the "format" form of the I/O
2526              statement.  We set the io_unit to the default unit and format to
2527              the character expression.  See F95 Standard section 9.4.  */
2528           io_kind k;
2529           k = dt->extra_comma->value.iokind;
2530           if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2531             {
2532               dt->format_expr = dt->io_unit;
2533               dt->io_unit = default_unit (k);
2534
2535               /* Free this pointer now so that a warning/error is not triggered
2536                  below for the "Extension".  */
2537               gfc_free_expr (dt->extra_comma);
2538               dt->extra_comma = NULL;
2539             }
2540
2541           if (k == M_WRITE)
2542             {
2543               gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2544                          &dt->extra_comma->where);
2545               return FAILURE;
2546             }
2547         }
2548     }
2549
2550   if (e->ts.type == BT_CHARACTER)
2551     {
2552       if (gfc_has_vector_index (e))
2553         {
2554           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2555           return FAILURE;
2556         }
2557     }
2558
2559   if (e->rank && e->ts.type != BT_CHARACTER)
2560     {
2561       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2562       return FAILURE;
2563     }
2564
2565   if (dt->extra_comma
2566       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2567                          "item list at %L", &dt->extra_comma->where) == FAILURE)
2568     return FAILURE;
2569
2570   if (dt->err)
2571     {
2572       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2573         return FAILURE;
2574       if (dt->err->defined == ST_LABEL_UNKNOWN)
2575         {
2576           gfc_error ("ERR tag label %d at %L not defined",
2577                       dt->err->value, &dt->err_where);
2578           return FAILURE;
2579         }
2580     }
2581
2582   if (dt->end)
2583     {
2584       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2585         return FAILURE;
2586       if (dt->end->defined == ST_LABEL_UNKNOWN)
2587         {
2588           gfc_error ("END tag label %d at %L not defined",
2589                       dt->end->value, &dt->end_where);
2590           return FAILURE;
2591         }
2592     }
2593
2594   if (dt->eor)
2595     {
2596       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2597         return FAILURE;
2598       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2599         {
2600           gfc_error ("EOR tag label %d at %L not defined",
2601                       dt->eor->value, &dt->eor_where);
2602           return FAILURE;
2603         }
2604     }
2605
2606   /* Check the format label actually exists.  */
2607   if (dt->format_label && dt->format_label != &format_asterisk
2608       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2609     {
2610       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2611                  &dt->format_label->where);
2612       return FAILURE;
2613     }
2614   return SUCCESS;
2615 }
2616
2617
2618 /* Given an io_kind, return its name.  */
2619
2620 static const char *
2621 io_kind_name (io_kind k)
2622 {
2623   const char *name;
2624
2625   switch (k)
2626     {
2627     case M_READ:
2628       name = "READ";
2629       break;
2630     case M_WRITE:
2631       name = "WRITE";
2632       break;
2633     case M_PRINT:
2634       name = "PRINT";
2635       break;
2636     case M_INQUIRE:
2637       name = "INQUIRE";
2638       break;
2639     default:
2640       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2641     }
2642
2643   return name;
2644 }
2645
2646
2647 /* Match an IO iteration statement of the form:
2648
2649    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2650
2651    which is equivalent to a single IO element.  This function is
2652    mutually recursive with match_io_element().  */
2653
2654 static match match_io_element (io_kind, gfc_code **);
2655
2656 static match
2657 match_io_iterator (io_kind k, gfc_code **result)
2658 {
2659   gfc_code *head, *tail, *new_code;
2660   gfc_iterator *iter;
2661   locus old_loc;
2662   match m;
2663   int n;
2664
2665   iter = NULL;
2666   head = NULL;
2667   old_loc = gfc_current_locus;
2668
2669   if (gfc_match_char ('(') != MATCH_YES)
2670     return MATCH_NO;
2671
2672   m = match_io_element (k, &head);
2673   tail = head;
2674
2675   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2676     {
2677       m = MATCH_NO;
2678       goto cleanup;
2679     }
2680
2681   /* Can't be anything but an IO iterator.  Build a list.  */
2682   iter = gfc_get_iterator ();
2683
2684   for (n = 1;; n++)
2685     {
2686       m = gfc_match_iterator (iter, 0);
2687       if (m == MATCH_ERROR)
2688         goto cleanup;
2689       if (m == MATCH_YES)
2690         {
2691           gfc_check_do_variable (iter->var->symtree);
2692           break;
2693         }
2694
2695       m = match_io_element (k, &new_code);
2696       if (m == MATCH_ERROR)
2697         goto cleanup;
2698       if (m == MATCH_NO)
2699         {
2700           if (n > 2)
2701             goto syntax;
2702           goto cleanup;
2703         }
2704
2705       tail = gfc_append_code (tail, new_code);
2706
2707       if (gfc_match_char (',') != MATCH_YES)
2708         {
2709           if (n > 2)
2710             goto syntax;
2711           m = MATCH_NO;
2712           goto cleanup;
2713         }
2714     }
2715
2716   if (gfc_match_char (')') != MATCH_YES)
2717     goto syntax;
2718
2719   new_code = gfc_get_code ();
2720   new_code->op = EXEC_DO;
2721   new_code->ext.iterator = iter;
2722
2723   new_code->block = gfc_get_code ();
2724   new_code->block->op = EXEC_DO;
2725   new_code->block->next = head;
2726
2727   *result = new_code;
2728   return MATCH_YES;
2729
2730 syntax:
2731   gfc_error ("Syntax error in I/O iterator at %C");
2732   m = MATCH_ERROR;
2733
2734 cleanup:
2735   gfc_free_iterator (iter, 1);
2736   gfc_free_statements (head);
2737   gfc_current_locus = old_loc;
2738   return m;
2739 }
2740
2741
2742 /* Match a single element of an IO list, which is either a single
2743    expression or an IO Iterator.  */
2744
2745 static match
2746 match_io_element (io_kind k, gfc_code **cpp)
2747 {
2748   gfc_expr *expr;
2749   gfc_code *cp;
2750   match m;
2751
2752   expr = NULL;
2753
2754   m = match_io_iterator (k, cpp);
2755   if (m == MATCH_YES)
2756     return MATCH_YES;
2757
2758   if (k == M_READ)
2759     {
2760       m = gfc_match_variable (&expr, 0);
2761       if (m == MATCH_NO)
2762         gfc_error ("Expected variable in READ statement at %C");
2763     }
2764   else
2765     {
2766       m = gfc_match_expr (&expr);
2767       if (m == MATCH_NO)
2768         gfc_error ("Expected expression in %s statement at %C",
2769                    io_kind_name (k));
2770     }
2771
2772   if (m == MATCH_YES)
2773     switch (k)
2774       {
2775       case M_READ:
2776         if (expr->symtree->n.sym->attr.intent == INTENT_IN)
2777           {
2778             gfc_error ("Variable '%s' in input list at %C cannot be "
2779                        "INTENT(IN)", expr->symtree->n.sym->name);
2780             m = MATCH_ERROR;
2781           }
2782
2783         if (gfc_pure (NULL)
2784             && gfc_impure_variable (expr->symtree->n.sym)
2785             && current_dt->io_unit->ts.type == BT_CHARACTER)
2786           {
2787             gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
2788                        expr->symtree->n.sym->name);
2789             m = MATCH_ERROR;
2790           }
2791
2792         if (gfc_check_do_variable (expr->symtree))
2793           m = MATCH_ERROR;
2794
2795         break;
2796
2797       case M_WRITE:
2798         if (current_dt->io_unit->ts.type == BT_CHARACTER
2799             && gfc_pure (NULL)
2800             && current_dt->io_unit->expr_type == EXPR_VARIABLE
2801             && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
2802           {
2803             gfc_error ("Cannot write to internal file unit '%s' at %C "
2804                        "inside a PURE procedure",
2805                        current_dt->io_unit->symtree->n.sym->name);
2806             m = MATCH_ERROR;
2807           }
2808
2809         break;
2810
2811       default:
2812         break;
2813       }
2814
2815   if (m != MATCH_YES)
2816     {
2817       gfc_free_expr (expr);
2818       return MATCH_ERROR;
2819     }
2820
2821   cp = gfc_get_code ();
2822   cp->op = EXEC_TRANSFER;
2823   cp->expr = expr;
2824
2825   *cpp = cp;
2826   return MATCH_YES;
2827 }
2828
2829
2830 /* Match an I/O list, building gfc_code structures as we go.  */
2831
2832 static match
2833 match_io_list (io_kind k, gfc_code **head_p)
2834 {
2835   gfc_code *head, *tail, *new_code;
2836   match m;
2837
2838   *head_p = head = tail = NULL;
2839   if (gfc_match_eos () == MATCH_YES)
2840     return MATCH_YES;
2841
2842   for (;;)
2843     {
2844       m = match_io_element (k, &new_code);
2845       if (m == MATCH_ERROR)
2846         goto cleanup;
2847       if (m == MATCH_NO)
2848         goto syntax;
2849
2850       tail = gfc_append_code (tail, new_code);
2851       if (head == NULL)
2852         head = new_code;
2853
2854       if (gfc_match_eos () == MATCH_YES)
2855         break;
2856       if (gfc_match_char (',') != MATCH_YES)
2857         goto syntax;
2858     }
2859
2860   *head_p = head;
2861   return MATCH_YES;
2862
2863 syntax:
2864   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2865
2866 cleanup:
2867   gfc_free_statements (head);
2868   return MATCH_ERROR;
2869 }
2870
2871
2872 /* Attach the data transfer end node.  */
2873
2874 static void
2875 terminate_io (gfc_code *io_code)
2876 {
2877   gfc_code *c;
2878
2879   if (io_code == NULL)
2880     io_code = new_st.block;
2881
2882   c = gfc_get_code ();
2883   c->op = EXEC_DT_END;
2884
2885   /* Point to structure that is already there */
2886   c->ext.dt = new_st.ext.dt;
2887   gfc_append_code (io_code, c);
2888 }
2889
2890
2891 /* Check the constraints for a data transfer statement.  The majority of the
2892    constraints appearing in 9.4 of the standard appear here.  Some are handled
2893    in resolve_tag and others in gfc_resolve_dt.  */
2894
2895 static match
2896 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
2897                       locus *spec_end)
2898 {
2899 #define io_constraint(condition,msg,arg)\
2900 if (condition) \
2901   {\
2902     gfc_error(msg,arg);\
2903     m = MATCH_ERROR;\
2904   }
2905
2906   match m;
2907   gfc_expr *expr;
2908   gfc_symbol *sym = NULL;
2909   bool warn, unformatted;
2910
2911   warn = (dt->err || dt->iostat) ? true : false;
2912   unformatted = dt->format_expr == NULL && dt->format_label == NULL
2913                 && dt->namelist == NULL;
2914
2915   m = MATCH_YES;
2916
2917   expr = dt->io_unit;
2918   if (expr && expr->expr_type == EXPR_VARIABLE
2919       && expr->ts.type == BT_CHARACTER)
2920     {
2921       sym = expr->symtree->n.sym;
2922
2923       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
2924                      "Internal file at %L must not be INTENT(IN)",
2925                      &expr->where);
2926
2927       io_constraint (gfc_has_vector_index (dt->io_unit),
2928                      "Internal file incompatible with vector subscript at %L",
2929                      &expr->where);
2930
2931       io_constraint (dt->rec != NULL,
2932                      "REC tag at %L is incompatible with internal file",
2933                      &dt->rec->where);
2934
2935       io_constraint (dt->pos != NULL,
2936                      "POS tag at %L is incompatible with internal file",
2937                      &dt->pos->where);
2938
2939       io_constraint (unformatted,
2940                      "Unformatted I/O not allowed with internal unit at %L",
2941                      &dt->io_unit->where);
2942
2943       io_constraint (dt->asynchronous != NULL,
2944                      "ASYNCHRONOUS tag at %L not allowed with internal file",
2945                      &dt->asynchronous->where);
2946
2947       if (dt->namelist != NULL)
2948         {
2949           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
2950                               "at %L with namelist", &expr->where)
2951               == FAILURE)
2952             m = MATCH_ERROR;
2953         }
2954
2955       io_constraint (dt->advance != NULL,
2956                      "ADVANCE tag at %L is incompatible with internal file",
2957                      &dt->advance->where);
2958     }
2959
2960   if (expr && expr->ts.type != BT_CHARACTER)
2961     {
2962
2963       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
2964                      "IO UNIT in %s statement at %C must be "
2965                      "an internal file in a PURE procedure",
2966                      io_kind_name (k));
2967     }
2968
2969   if (k != M_READ)
2970     {
2971       io_constraint (dt->end, "END tag not allowed with output at %L",
2972                      &dt->end_where);
2973
2974       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
2975                      &dt->eor_where);
2976
2977       io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
2978                      &dt->blank->where);
2979
2980       io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
2981                      &dt->pad->where);
2982
2983       io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
2984                      &dt->size->where);
2985     }
2986   else
2987     {
2988       io_constraint (dt->size && dt->advance == NULL,
2989                      "SIZE tag at %L requires an ADVANCE tag",
2990                      &dt->size->where);
2991
2992       io_constraint (dt->eor && dt->advance == NULL,
2993                      "EOR tag at %L requires an ADVANCE tag",
2994                      &dt->eor_where);
2995     }
2996
2997   if (dt->asynchronous)
2998     {
2999       static const char * asynchronous[] = { "YES", "NO", NULL };
3000
3001       if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3002         {
3003           gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3004                      "expression", &dt->asynchronous->where);
3005           return MATCH_ERROR;
3006         }
3007
3008       if (!compare_to_allowed_values
3009                 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3010                  dt->asynchronous->value.character.string,
3011                  io_kind_name (k), warn))
3012         return MATCH_ERROR;
3013     }
3014
3015   if (dt->id)
3016     {
3017       bool not_yes
3018         = !dt->asynchronous
3019           || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3020           || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3021                                    "yes", 3) != 0;
3022       io_constraint (not_yes,
3023                      "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3024                      "specifier", &dt->id->where);
3025     }
3026
3027   if (dt->decimal)
3028     {
3029       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3030           "not allowed in Fortran 95") == FAILURE)
3031         return MATCH_ERROR;
3032
3033       if (dt->decimal->expr_type == EXPR_CONSTANT)
3034         {
3035           static const char * decimal[] = { "COMMA", "POINT", NULL };
3036
3037           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3038                                           dt->decimal->value.character.string,
3039                                           io_kind_name (k), warn))
3040             return MATCH_ERROR;
3041
3042           io_constraint (unformatted,
3043                          "the DECIMAL= specifier at %L must be with an "
3044                          "explicit format expression", &dt->decimal->where);
3045         }
3046     }
3047
3048   if (dt->blank)
3049     {
3050       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3051           "not allowed in Fortran 95") == FAILURE)
3052         return MATCH_ERROR;
3053
3054       if (dt->blank->expr_type == EXPR_CONSTANT)
3055         {
3056           static const char * blank[] = { "NULL", "ZERO", NULL };
3057
3058           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3059                                           dt->blank->value.character.string,
3060                                           io_kind_name (k), warn))
3061             return MATCH_ERROR;
3062
3063           io_constraint (unformatted,
3064                          "the BLANK= specifier at %L must be with an "
3065                          "explicit format expression", &dt->blank->where);
3066         }
3067     }
3068
3069   if (dt->pad)
3070     {
3071       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3072           "not allowed in Fortran 95") == FAILURE)
3073         return MATCH_ERROR;
3074
3075       if (dt->pad->expr_type == EXPR_CONSTANT)
3076         {
3077           static const char * pad[] = { "YES", "NO", NULL };
3078
3079           if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3080                                           dt->pad->value.character.string,
3081                                           io_kind_name (k), warn))
3082             return MATCH_ERROR;
3083
3084           io_constraint (unformatted,
3085                          "the PAD= specifier at %L must be with an "
3086                          "explicit format expression", &dt->pad->where);
3087         }
3088     }
3089
3090   if (dt->round)
3091     {
3092       /* When implemented, change the following to use gfc_notify_std F2003.
3093       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3094           "not allowed in Fortran 95") == FAILURE)
3095         return MATCH_ERROR;  */
3096       gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
3097       return MATCH_ERROR;
3098
3099       if (dt->round->expr_type == EXPR_CONSTANT)
3100         {
3101           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3102                                           "COMPATIBLE", "PROCESSOR_DEFINED",
3103                                           NULL };
3104
3105           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3106                                           dt->round->value.character.string,
3107                                           io_kind_name (k), warn))
3108             return MATCH_ERROR;
3109         }
3110     }
3111
3112   if (dt->sign)
3113     {
3114       /* When implemented, change the following to use gfc_notify_std F2003.
3115       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3116           "not allowed in Fortran 95") == FAILURE)
3117         return MATCH_ERROR;  */
3118       if (dt->sign->expr_type == EXPR_CONSTANT)
3119         {
3120           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3121                                          NULL };
3122
3123           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3124                                       dt->sign->value.character.string,
3125                                       io_kind_name (k), warn))
3126             return MATCH_ERROR;
3127
3128           io_constraint (unformatted,
3129                          "SIGN= specifier at %L must be with an "
3130                          "explicit format expression", &dt->sign->where);
3131
3132           io_constraint (k == M_READ,
3133                          "SIGN= specifier at %L not allowed in a "
3134                          "READ statement", &dt->sign->where);
3135         }
3136     }
3137
3138   if (dt->delim)
3139     {
3140       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3141           "not allowed in Fortran 95") == FAILURE)
3142         return MATCH_ERROR;
3143
3144       if (dt->delim->expr_type == EXPR_CONSTANT)
3145         {
3146           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3147
3148           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3149                                           dt->delim->value.character.string,
3150                                           io_kind_name (k), warn))
3151             return MATCH_ERROR;
3152
3153           io_constraint (k == M_READ,
3154                          "DELIM= specifier at %L not allowed in a "
3155                          "READ statement", &dt->delim->where);
3156
3157           io_constraint (dt->format_label != &format_asterisk
3158                          && dt->namelist == NULL,
3159                          "DELIM= specifier at %L must have FMT=*",
3160                          &dt->delim->where);
3161
3162           io_constraint (unformatted && dt->namelist == NULL,
3163                          "DELIM= specifier at %L must be with FMT=* or "
3164                          "NML= specifier ", &dt->delim->where);
3165         }
3166     }
3167
3168   if (dt->namelist)
3169     {
3170       io_constraint (io_code && dt->namelist,
3171                      "NAMELIST cannot be followed by IO-list at %L",
3172                      &io_code->loc);
3173
3174       io_constraint (dt->format_expr,
3175                      "IO spec-list cannot contain both NAMELIST group name "
3176                      "and format specification at %L",
3177                      &dt->format_expr->where);
3178
3179       io_constraint (dt->format_label,
3180                      "IO spec-list cannot contain both NAMELIST group name "
3181                      "and format label at %L", spec_end);
3182
3183       io_constraint (dt->rec,
3184                      "NAMELIST IO is not allowed with a REC= specifier "
3185                      "at %L", &dt->rec->where);
3186
3187       io_constraint (dt->advance,
3188                      "NAMELIST IO is not allowed with a ADVANCE= specifier "
3189                      "at %L", &dt->advance->where);
3190     }
3191
3192   if (dt->rec)
3193     {
3194       io_constraint (dt->end,
3195                      "An END tag is not allowed with a "
3196                      "REC= specifier at %L", &dt->end_where);
3197
3198       io_constraint (dt->format_label == &format_asterisk,
3199                      "FMT=* is not allowed with a REC= specifier "
3200                      "at %L", spec_end);
3201
3202       io_constraint (dt->pos,
3203                      "POS= is not allowed with REC= specifier "
3204                      "at %L", &dt->pos->where);
3205     }
3206
3207   if (dt->advance)
3208     {
3209       int not_yes, not_no;
3210       expr = dt->advance;
3211
3212       io_constraint (dt->format_label == &format_asterisk,
3213                      "List directed format(*) is not allowed with a "
3214                      "ADVANCE= specifier at %L.", &expr->where);
3215
3216       io_constraint (unformatted,
3217                      "the ADVANCE= specifier at %L must appear with an "
3218                      "explicit format expression", &expr->where);
3219
3220       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3221         {
3222           const gfc_char_t *advance = expr->value.character.string;
3223           not_no = gfc_wide_strlen (advance) != 2
3224                    || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3225           not_yes = gfc_wide_strlen (advance) != 3
3226                     || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3227         }
3228       else
3229         {
3230           not_no = 0;
3231           not_yes = 0;
3232         }
3233
3234       io_constraint (not_no && not_yes,
3235                      "ADVANCE= specifier at %L must have value = "
3236                      "YES or NO.", &expr->where);
3237
3238       io_constraint (dt->size && not_no && k == M_READ,
3239                      "SIZE tag at %L requires an ADVANCE = 'NO'",
3240                      &dt->size->where);
3241
3242       io_constraint (dt->eor && not_no && k == M_READ,
3243                      "EOR tag at %L requires an ADVANCE = 'NO'",
3244                      &dt->eor_where);
3245     }
3246
3247   expr = dt->format_expr;
3248   if (gfc_simplify_expr (expr, 0) == FAILURE
3249       || check_format_string (expr, k == M_READ) == FAILURE)
3250     return MATCH_ERROR;
3251
3252   return m;
3253 }
3254 #undef io_constraint
3255
3256
3257 /* Match a READ, WRITE or PRINT statement.  */
3258
3259 static match
3260 match_io (io_kind k)
3261 {
3262   char name[GFC_MAX_SYMBOL_LEN + 1];
3263   gfc_code *io_code;
3264   gfc_symbol *sym;
3265   int comma_flag;
3266   locus where;
3267   locus spec_end;
3268   gfc_dt *dt;
3269   match m;
3270
3271   where = gfc_current_locus;
3272   comma_flag = 0;
3273   current_dt = dt = XCNEW (gfc_dt);
3274   m = gfc_match_char ('(');
3275   if (m == MATCH_NO)
3276     {
3277       where = gfc_current_locus;
3278       if (k == M_WRITE)
3279         goto syntax;
3280       else if (k == M_PRINT)
3281         {
3282           /* Treat the non-standard case of PRINT namelist.  */
3283           if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3284               && gfc_match_name (name) == MATCH_YES)
3285             {
3286               gfc_find_symbol (name, NULL, 1, &sym);
3287               if (sym && sym->attr.flavor == FL_NAMELIST)
3288                 {
3289                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3290                                       "%C is an extension") == FAILURE)
3291                     {
3292                       m = MATCH_ERROR;
3293                       goto cleanup;
3294                     }
3295
3296                   dt->io_unit = default_unit (k);
3297                   dt->namelist = sym;
3298                   goto get_io_list;
3299                 }
3300               else
3301                 gfc_current_locus = where;
3302             }
3303         }
3304
3305       if (gfc_current_form == FORM_FREE)
3306         {
3307           char c = gfc_peek_ascii_char ();
3308           if (c != ' ' && c != '*' && c != '\'' && c != '"')
3309             {
3310               m = MATCH_NO;
3311               goto cleanup;
3312             }
3313         }
3314
3315       m = match_dt_format (dt);
3316       if (m == MATCH_ERROR)
3317         goto cleanup;
3318       if (m == MATCH_NO)
3319         goto syntax;
3320
3321       comma_flag = 1;
3322       dt->io_unit = default_unit (k);
3323       goto get_io_list;
3324     }
3325   else
3326     {
3327       /* Before issuing an error for a malformed 'print (1,*)' type of
3328          error, check for a default-char-expr of the form ('(I0)').  */
3329       if (k == M_PRINT && m == MATCH_YES)
3330         {
3331           /* Reset current locus to get the initial '(' in an expression.  */
3332           gfc_current_locus = where;
3333           dt->format_expr = NULL;
3334           m = match_dt_format (dt);
3335
3336           if (m == MATCH_ERROR)
3337             goto cleanup;
3338           if (m == MATCH_NO || dt->format_expr == NULL)
3339             goto syntax;
3340
3341           comma_flag = 1;
3342           dt->io_unit = default_unit (k);
3343           goto get_io_list;
3344         }
3345     }
3346
3347   /* Match a control list */
3348   if (match_dt_element (k, dt) == MATCH_YES)
3349     goto next;
3350   if (match_dt_unit (k, dt) != MATCH_YES)
3351     goto loop;
3352
3353   if (gfc_match_char (')') == MATCH_YES)
3354     goto get_io_list;
3355   if (gfc_match_char (',') != MATCH_YES)
3356     goto syntax;
3357
3358   m = match_dt_element (k, dt);
3359   if (m == MATCH_YES)
3360     goto next;
3361   if (m == MATCH_ERROR)
3362     goto cleanup;
3363
3364   m = match_dt_format (dt);
3365   if (m == MATCH_YES)
3366     goto next;
3367   if (m == MATCH_ERROR)
3368     goto cleanup;
3369
3370   where = gfc_current_locus;
3371
3372   m = gfc_match_name (name);
3373   if (m == MATCH_YES)
3374     {
3375       gfc_find_symbol (name, NULL, 1, &sym);
3376       if (sym && sym->attr.flavor == FL_NAMELIST)
3377         {
3378           dt->namelist = sym;
3379           if (k == M_READ && check_namelist (sym))
3380             {
3381               m = MATCH_ERROR;
3382               goto cleanup;
3383             }
3384           goto next;
3385         }
3386     }
3387
3388   gfc_current_locus = where;
3389
3390   goto loop;                    /* No matches, try regular elements */
3391
3392 next:
3393   if (gfc_match_char (')') == MATCH_YES)
3394     goto get_io_list;
3395   if (gfc_match_char (',') != MATCH_YES)
3396     goto syntax;
3397
3398 loop:
3399   for (;;)
3400     {
3401       m = match_dt_element (k, dt);
3402       if (m == MATCH_NO)
3403         goto syntax;
3404       if (m == MATCH_ERROR)
3405         goto cleanup;
3406
3407       if (gfc_match_char (')') == MATCH_YES)
3408         break;
3409       if (gfc_match_char (',') != MATCH_YES)
3410         goto syntax;
3411     }
3412
3413 get_io_list:
3414
3415   /* Used in check_io_constraints, where no locus is available.  */
3416   spec_end = gfc_current_locus;
3417
3418   /* Optional leading comma (non-standard).  We use a gfc_expr structure here
3419      to save the locus.  This is used later when resolving transfer statements
3420      that might have a format expression without unit number.  */
3421   if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3422     {
3423       dt->extra_comma = gfc_get_expr ();
3424
3425       /* Set the types to something compatible with iokind. This is needed to
3426          get through gfc_free_expr later since iokind really has no Basic Type,
3427          BT, of its own.  */
3428       dt->extra_comma->expr_type = EXPR_CONSTANT;
3429       dt->extra_comma->ts.type = BT_LOGICAL;
3430
3431       /* Save the iokind and locus for later use in resolution.  */
3432       dt->extra_comma->value.iokind = k;
3433       dt->extra_comma->where = gfc_current_locus;
3434     }
3435
3436   io_code = NULL;
3437   if (gfc_match_eos () != MATCH_YES)
3438     {
3439       if (comma_flag && gfc_match_char (',') != MATCH_YES)
3440         {
3441           gfc_error ("Expected comma in I/O list at %C");
3442           m = MATCH_ERROR;
3443           goto cleanup;
3444         }
3445
3446       m = match_io_list (k, &io_code);
3447       if (m == MATCH_ERROR)
3448         goto cleanup;
3449       if (m == MATCH_NO)
3450         goto syntax;
3451     }
3452
3453   /* A full IO statement has been matched.  Check the constraints.  spec_end is
3454      supplied for cases where no locus is supplied.  */
3455   m = check_io_constraints (k, dt, io_code, &spec_end);
3456
3457   if (m == MATCH_ERROR)
3458     goto cleanup;
3459
3460   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3461   new_st.ext.dt = dt;
3462   new_st.block = gfc_get_code ();
3463   new_st.block->op = new_st.op;
3464   new_st.block->next = io_code;
3465
3466   terminate_io (io_code);
3467
3468   return MATCH_YES;
3469
3470 syntax:
3471   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3472   m = MATCH_ERROR;
3473
3474 cleanup:
3475   gfc_free_dt (dt);
3476   return m;
3477 }
3478
3479
3480 match
3481 gfc_match_read (void)
3482 {
3483   return match_io (M_READ);
3484 }
3485
3486
3487 match
3488 gfc_match_write (void)
3489 {
3490   return match_io (M_WRITE);
3491 }
3492
3493
3494 match
3495 gfc_match_print (void)
3496 {
3497   match m;
3498
3499   m = match_io (M_PRINT);
3500   if (m != MATCH_YES)
3501     return m;
3502
3503   if (gfc_pure (NULL))
3504     {
3505       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3506       return MATCH_ERROR;
3507     }
3508
3509   return MATCH_YES;
3510 }
3511
3512
3513 /* Free a gfc_inquire structure.  */
3514
3515 void
3516 gfc_free_inquire (gfc_inquire *inquire)
3517 {
3518
3519   if (inquire == NULL)
3520     return;
3521
3522   gfc_free_expr (inquire->unit);
3523   gfc_free_expr (inquire->file);
3524   gfc_free_expr (inquire->iomsg);
3525   gfc_free_expr (inquire->iostat);
3526   gfc_free_expr (inquire->exist);
3527   gfc_free_expr (inquire->opened);
3528   gfc_free_expr (inquire->number);
3529   gfc_free_expr (inquire->named);
3530   gfc_free_expr (inquire->name);
3531   gfc_free_expr (inquire->access);
3532   gfc_free_expr (inquire->sequential);
3533   gfc_free_expr (inquire->direct);
3534   gfc_free_expr (inquire->form);
3535   gfc_free_expr (inquire->formatted);
3536   gfc_free_expr (inquire->unformatted);
3537   gfc_free_expr (inquire->recl);
3538   gfc_free_expr (inquire->nextrec);
3539   gfc_free_expr (inquire->blank);
3540   gfc_free_expr (inquire->position);
3541   gfc_free_expr (inquire->action);
3542   gfc_free_expr (inquire->read);
3543   gfc_free_expr (inquire->write);
3544   gfc_free_expr (inquire->readwrite);
3545   gfc_free_expr (inquire->delim);
3546   gfc_free_expr (inquire->encoding);
3547   gfc_free_expr (inquire->pad);
3548   gfc_free_expr (inquire->iolength);
3549   gfc_free_expr (inquire->convert);
3550   gfc_free_expr (inquire->strm_pos);
3551   gfc_free_expr (inquire->asynchronous);
3552   gfc_free_expr (inquire->decimal);
3553   gfc_free_expr (inquire->pending);
3554   gfc_free_expr (inquire->id);
3555   gfc_free_expr (inquire->sign);
3556   gfc_free_expr (inquire->size);
3557   gfc_free_expr (inquire->round);
3558   gfc_free (inquire);
3559 }
3560
3561
3562 /* Match an element of an INQUIRE statement.  */
3563
3564 #define RETM   if (m != MATCH_NO) return m;
3565
3566 static match
3567 match_inquire_element (gfc_inquire *inquire)
3568 {
3569   match m;
3570
3571   m = match_etag (&tag_unit, &inquire->unit);
3572   RETM m = match_etag (&tag_file, &inquire->file);
3573   RETM m = match_ltag (&tag_err, &inquire->err);
3574   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3575   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3576   RETM m = match_vtag (&tag_exist, &inquire->exist);
3577   RETM m = match_vtag (&tag_opened, &inquire->opened);
3578   RETM m = match_vtag (&tag_named, &inquire->named);
3579   RETM m = match_vtag (&tag_name, &inquire->name);
3580   RETM m = match_out_tag (&tag_number, &inquire->number);
3581   RETM m = match_vtag (&tag_s_access, &inquire->access);
3582   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3583   RETM m = match_vtag (&tag_direct, &inquire->direct);
3584   RETM m = match_vtag (&tag_s_form, &inquire->form);
3585   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3586   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3587   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3588   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3589   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3590   RETM m = match_vtag (&tag_s_position, &inquire->position);
3591   RETM m = match_vtag (&tag_s_action, &inquire->action);
3592   RETM m = match_vtag (&tag_read, &inquire->read);
3593   RETM m = match_vtag (&tag_write, &inquire->write);
3594   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3595   RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3596   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3597   RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3598   RETM m = match_vtag (&tag_size, &inquire->size);
3599   RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3600   RETM m = match_vtag (&tag_s_round, &inquire->round);
3601   RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3602   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3603   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3604   RETM m = match_vtag (&tag_convert, &inquire->convert);
3605   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3606   RETM m = match_vtag (&tag_pending, &inquire->pending);
3607   RETM m = match_vtag (&tag_id, &inquire->id);
3608   RETM return MATCH_NO;
3609 }
3610
3611 #undef RETM
3612
3613
3614 match
3615 gfc_match_inquire (void)
3616 {
3617   gfc_inquire *inquire;
3618   gfc_code *code;
3619   match m;
3620   locus loc;
3621
3622   m = gfc_match_char ('(');
3623   if (m == MATCH_NO)
3624     return m;
3625
3626   inquire = XCNEW (gfc_inquire);
3627
3628   loc = gfc_current_locus;
3629
3630   m = match_inquire_element (inquire);
3631   if (m == MATCH_ERROR)
3632     goto cleanup;
3633   if (m == MATCH_NO)
3634     {
3635       m = gfc_match_expr (&inquire->unit);
3636       if (m == MATCH_ERROR)
3637         goto cleanup;
3638       if (m == MATCH_NO)
3639         goto syntax;
3640     }
3641
3642   /* See if we have the IOLENGTH form of the inquire statement.  */
3643   if (inquire->iolength != NULL)
3644     {
3645       if (gfc_match_char (')') != MATCH_YES)
3646         goto syntax;
3647
3648       m = match_io_list (M_INQUIRE, &code);
3649       if (m == MATCH_ERROR)
3650         goto cleanup;
3651       if (m == MATCH_NO)
3652         goto syntax;
3653
3654       new_st.op = EXEC_IOLENGTH;
3655       new_st.expr = inquire->iolength;
3656       new_st.ext.inquire = inquire;
3657
3658       if (gfc_pure (NULL))
3659         {
3660           gfc_free_statements (code);
3661           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3662           return MATCH_ERROR;
3663         }
3664
3665       new_st.block = gfc_get_code ();
3666       new_st.block->op = EXEC_IOLENGTH;
3667       terminate_io (code);
3668       new_st.block->next = code;
3669       return MATCH_YES;
3670     }
3671
3672   /* At this point, we have the non-IOLENGTH inquire statement.  */
3673   for (;;)
3674     {
3675       if (gfc_match_char (')') == MATCH_YES)
3676         break;
3677       if (gfc_match_char (',') != MATCH_YES)
3678         goto syntax;
3679
3680       m = match_inquire_element (inquire);
3681       if (m == MATCH_ERROR)
3682         goto cleanup;
3683       if (m == MATCH_NO)
3684         goto syntax;
3685
3686       if (inquire->iolength != NULL)
3687         {
3688           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3689           goto cleanup;
3690         }
3691     }
3692
3693   if (gfc_match_eos () != MATCH_YES)
3694     goto syntax;
3695
3696   if (inquire->unit != NULL && inquire->file != NULL)
3697     {
3698       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3699                  "UNIT specifiers", &loc);
3700       goto cleanup;
3701     }
3702
3703   if (inquire->unit == NULL && inquire->file == NULL)
3704     {
3705       gfc_error ("INQUIRE statement at %L requires either FILE or "
3706                  "UNIT specifier", &loc);
3707       goto cleanup;
3708     }
3709
3710   if (gfc_pure (NULL))
3711     {
3712       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3713       goto cleanup;
3714     }
3715
3716   if (inquire->id != NULL && inquire->pending == NULL)
3717     {
3718       gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3719                  "the ID= specifier", &loc);
3720       goto cleanup;
3721     }
3722
3723   new_st.op = EXEC_INQUIRE;
3724   new_st.ext.inquire = inquire;
3725   return MATCH_YES;
3726
3727 syntax:
3728   gfc_syntax_error (ST_INQUIRE);
3729
3730 cleanup:
3731   gfc_free_inquire (inquire);
3732   return MATCH_ERROR;
3733 }
3734
3735
3736 /* Resolve everything in a gfc_inquire structure.  */
3737
3738 gfc_try
3739 gfc_resolve_inquire (gfc_inquire *inquire)
3740 {
3741   RESOLVE_TAG (&tag_unit, inquire->unit);
3742   RESOLVE_TAG (&tag_file, inquire->file);
3743   RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
3744   RESOLVE_TAG (&tag_iostat, inquire->iostat);
3745   RESOLVE_TAG (&tag_exist, inquire->exist);
3746   RESOLVE_TAG (&tag_opened, inquire->opened);
3747   RESOLVE_TAG (&tag_number, inquire->number);
3748   RESOLVE_TAG (&tag_named, inquire->named);
3749   RESOLVE_TAG (&tag_name, inquire->name);
3750   RESOLVE_TAG (&tag_s_access, inquire->access);
3751   RESOLVE_TAG (&tag_sequential, inquire->sequential);
3752   RESOLVE_TAG (&tag_direct, inquire->direct);
3753   RESOLVE_TAG (&tag_s_form, inquire->form);
3754   RESOLVE_TAG (&tag_formatted, inquire->formatted);
3755   RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
3756   RESOLVE_TAG (&tag_s_recl, inquire->recl);
3757   RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
3758   RESOLVE_TAG (&tag_s_blank, inquire->blank);
3759   RESOLVE_TAG (&tag_s_position, inquire->position);
3760   RESOLVE_TAG (&tag_s_action, inquire->action);
3761   RESOLVE_TAG (&tag_read, inquire->read);
3762   RESOLVE_TAG (&tag_write, inquire->write);
3763   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
3764   RESOLVE_TAG (&tag_s_delim, inquire->delim);
3765   RESOLVE_TAG (&tag_s_pad, inquire->pad);
3766   RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
3767   RESOLVE_TAG (&tag_s_round, inquire->round);
3768   RESOLVE_TAG (&tag_iolength, inquire->iolength);
3769   RESOLVE_TAG (&tag_convert, inquire->convert);
3770   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
3771   RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
3772   RESOLVE_TAG (&tag_s_sign, inquire->sign);
3773   RESOLVE_TAG (&tag_s_round, inquire->round);
3774   RESOLVE_TAG (&tag_pending, inquire->pending);
3775   RESOLVE_TAG (&tag_size, inquire->size);
3776   RESOLVE_TAG (&tag_id, inquire->id);
3777
3778   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
3779     return FAILURE;
3780
3781   return SUCCESS;
3782 }
3783
3784
3785 void
3786 gfc_free_wait (gfc_wait *wait)
3787 {
3788   if (wait == NULL)
3789     return;
3790
3791   gfc_free_expr (wait->unit);
3792   gfc_free_expr (wait->iostat);
3793   gfc_free_expr (wait->iomsg);
3794   gfc_free_expr (wait->id);
3795 }
3796
3797
3798 gfc_try
3799 gfc_resolve_wait (gfc_wait *wait)
3800 {
3801   RESOLVE_TAG (&tag_unit, wait->unit);
3802   RESOLVE_TAG (&tag_iomsg, wait->iomsg);
3803   RESOLVE_TAG (&tag_iostat, wait->iostat);
3804   RESOLVE_TAG (&tag_id, wait->id);
3805
3806   if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
3807     return FAILURE;
3808
3809   if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
3810     return FAILURE;
3811
3812   return SUCCESS;
3813 }
3814
3815 /* Match an element of a WAIT statement.  */
3816
3817 #define RETM   if (m != MATCH_NO) return m;
3818
3819 static match
3820 match_wait_element (gfc_wait *wait)
3821 {
3822   match m;
3823
3824   m = match_etag (&tag_unit, &wait->unit);
3825   RETM m = match_ltag (&tag_err, &wait->err);
3826   RETM m = match_ltag (&tag_end, &wait->eor);
3827   RETM m = match_ltag (&tag_eor, &wait->end);
3828   RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
3829   RETM m = match_out_tag (&tag_iostat, &wait->iostat);
3830   RETM m = match_etag (&tag_id, &wait->id);
3831   RETM return MATCH_NO;
3832 }
3833
3834 #undef RETM
3835
3836
3837 match
3838 gfc_match_wait (void)
3839 {
3840   gfc_wait *wait;
3841   match m;
3842   locus loc;
3843
3844   m = gfc_match_char ('(');
3845   if (m == MATCH_NO)
3846     return m;
3847
3848   wait = XCNEW (gfc_wait);
3849
3850   loc = gfc_current_locus;
3851
3852   m = match_wait_element (wait);
3853   if (m == MATCH_ERROR)
3854     goto cleanup;
3855   if (m == MATCH_NO)
3856     {
3857       m = gfc_match_expr (&wait->unit);
3858       if (m == MATCH_ERROR)
3859         goto cleanup;
3860       if (m == MATCH_NO)
3861         goto syntax;
3862     }
3863
3864   for (;;)
3865     {
3866       if (gfc_match_char (')') == MATCH_YES)
3867         break;
3868       if (gfc_match_char (',') != MATCH_YES)
3869         goto syntax;
3870
3871       m = match_wait_element (wait);
3872       if (m == MATCH_ERROR)
3873         goto cleanup;
3874       if (m == MATCH_NO)
3875         goto syntax;
3876     }
3877
3878   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
3879           "not allowed in Fortran 95") == FAILURE)
3880     goto cleanup;
3881
3882   if (gfc_pure (NULL))
3883     {
3884       gfc_error ("WAIT statement not allowed in PURE procedure at %C");
3885       goto cleanup;
3886     }
3887
3888   new_st.op = EXEC_WAIT;
3889   new_st.ext.wait = wait;
3890
3891   return MATCH_YES;
3892
3893 syntax:
3894   gfc_syntax_error (ST_WAIT);
3895
3896 cleanup:
3897   gfc_free_wait (wait);
3898   return MATCH_ERROR;
3899 }