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