gcc/fortran/io.c

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