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, 2011
   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 (gfc_instring 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 (NONSTRING);
 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 (INSTRING_WARN);
 378           if (c == '\0')
 379             {
 380               token = FMT_END;
 381               break;
 382             }
 383
 384           if (c == delim)
 385             {
 386               c = next_char (INSTRING_NOWARN);
 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 (INSTRING_WARN);
 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   if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1319     gfc_current_ns->proc_name->attr.implicit_pure = 0;
1320
1321   *v = result;
1322   return MATCH_YES;
1323 }
1324
1325
1326 /* Match I/O tags that cause variables to become redefined.  */
1327
1328 static match
1329 match_out_tag (const io_tag *tag, gfc_expr **result)
1330 {
1331   match m;
1332
1333   m = match_vtag (tag, result);
1334   if (m == MATCH_YES)
1335     gfc_check_do_variable ((*result)->symtree);
1336
1337   return m;
1338 }
1339
1340
1341 /* Match a label I/O tag.  */
1342
1343 static match
1344 match_ltag (const io_tag *tag, gfc_st_label ** label)
1345 {
1346   match m;
1347   gfc_st_label *old;
1348
1349   old = *label;
1350   m = gfc_match (tag->spec);
1351   if (m != MATCH_YES)
1352     return m;
1353
1354   m = gfc_match (tag->value, label);
1355   if (m != MATCH_YES)
1356     {
1357       gfc_error ("Invalid value for %s specification at %C", tag->name);
1358       return MATCH_ERROR;
1359     }
1360
1361   if (old)
1362     {
1363       gfc_error ("Duplicate %s label specification at %C", tag->name);
1364       return MATCH_ERROR;
1365     }
1366
1367   if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1368     return MATCH_ERROR;
1369
1370   return m;
1371 }
1372
1373
1374 /* Resolution of the FORMAT tag, to be called from resolve_tag.  */
1375
1376 static gfc_try
1377 resolve_tag_format (const gfc_expr *e)
1378 {
1379   if (e->expr_type == EXPR_CONSTANT
1380       && (e->ts.type != BT_CHARACTER
1381           || e->ts.kind != gfc_default_character_kind))
1382     {
1383       gfc_error ("Constant expression in FORMAT tag at %L must be "
1384                  "of type default CHARACTER", &e->where);
1385       return FAILURE;
1386     }
1387
1388   /* If e's rank is zero and e is not an element of an array, it should be
1389      of integer or character type.  The integer variable should be
1390      ASSIGNED.  */
1391   if (e->rank == 0
1392       && (e->expr_type != EXPR_VARIABLE
1393           || e->symtree == NULL
1394           || e->symtree->n.sym->as == NULL
1395           || e->symtree->n.sym->as->rank == 0))
1396     {
1397       if ((e->ts.type != BT_CHARACTER
1398            || e->ts.kind != gfc_default_character_kind)
1399           && e->ts.type != BT_INTEGER)
1400         {
1401           gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1402                      "or of INTEGER", &e->where);
1403           return FAILURE;
1404         }
1405       else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1406         {
1407           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1408                               "variable in FORMAT tag at %L", &e->where)
1409               == FAILURE)
1410             return FAILURE;
1411           if (e->symtree->n.sym->attr.assign != 1)
1412             {
1413               gfc_error ("Variable '%s' at %L has not been assigned a "
1414                          "format label", e->symtree->n.sym->name, &e->where);
1415               return FAILURE;
1416             }
1417         }
1418       else if (e->ts.type == BT_INTEGER)
1419         {
1420           gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1421                      "variable", gfc_basic_typename (e->ts.type), &e->where);
1422           return FAILURE;
1423         }
1424
1425       return SUCCESS;
1426     }
1427
1428   /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1429      It may be assigned an Hollerith constant.  */
1430   if (e->ts.type != BT_CHARACTER)
1431     {
1432       if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1433                           "in FORMAT tag at %L", &e->where) == FAILURE)
1434         return FAILURE;
1435
1436       if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1437         {
1438           gfc_error ("Non-character assumed shape array element in FORMAT"
1439                      " tag at %L", &e->where);
1440           return FAILURE;
1441         }
1442
1443       if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1444         {
1445           gfc_error ("Non-character assumed size array element in FORMAT"
1446                      " tag at %L", &e->where);
1447           return FAILURE;
1448         }
1449
1450       if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1451         {
1452           gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1453                      &e->where);
1454           return FAILURE;
1455         }
1456     }
1457
1458   return SUCCESS;
1459 }
1460
1461
1462 /* Do expression resolution and type-checking on an expression tag.  */
1463
1464 static gfc_try
1465 resolve_tag (const io_tag *tag, gfc_expr *e)
1466 {
1467   if (e == NULL)
1468     return SUCCESS;
1469
1470   if (gfc_resolve_expr (e) == FAILURE)
1471     return FAILURE;
1472
1473   if (tag == &tag_format)
1474     return resolve_tag_format (e);
1475
1476   if (e->ts.type != tag->type)
1477     {
1478       gfc_error ("%s tag at %L must be of type %s", tag->name,
1479                  &e->where, gfc_basic_typename (tag->type));
1480       return FAILURE;
1481     }
1482
1483   if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
1484     {
1485       gfc_error ("%s tag at %L must be a character string of default kind",
1486                  tag->name, &e->where);
1487       return FAILURE;
1488     }
1489
1490   if (e->rank != 0)
1491     {
1492       gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1493       return FAILURE;
1494     }
1495
1496   if (tag == &tag_iomsg)
1497     {
1498       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1499                           &e->where) == FAILURE)
1500         return FAILURE;
1501     }
1502
1503   if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1504       && e->ts.kind != gfc_default_integer_kind)
1505     {
1506       if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1507                           "INTEGER in %s tag at %L", tag->name, &e->where)
1508           == FAILURE)
1509         return FAILURE;
1510     }
1511
1512   if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind)
1513     {
1514       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Nondefault LOGICAL "
1515                           "in %s tag at %L", tag->name, &e->where)
1516           == FAILURE)
1517         return FAILURE;
1518     }
1519
1520   if (tag == &tag_newunit)
1521     {
1522       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: NEWUNIT specifier"
1523                           " at %L", &e->where) == FAILURE)
1524         return FAILURE;
1525     }
1526
1527   /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts.  */
1528   if (tag == &tag_newunit || tag == &tag_iostat
1529       || tag == &tag_size || tag == &tag_iomsg)
1530     {
1531       char context[64];
1532
1533       sprintf (context, _("%s tag"), tag->name);
1534       if (gfc_check_vardef_context (e, false, false, context) == FAILURE)
1535         return FAILURE;
1536     }
1537
1538   if (tag == &tag_convert)
1539     {
1540       if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1541                           &e->where) == FAILURE)
1542         return FAILURE;
1543     }
1544
1545   return SUCCESS;
1546 }
1547
1548
1549 /* Match a single tag of an OPEN statement.  */
1550
1551 static match
1552 match_open_element (gfc_open *open)
1553 {
1554   match m;
1555
1556   m = match_etag (&tag_e_async, &open->asynchronous);
1557   if (m != MATCH_NO)
1558     return m;
1559   m = match_etag (&tag_unit, &open->unit);
1560   if (m != MATCH_NO)
1561     return m;
1562   m = match_out_tag (&tag_iomsg, &open->iomsg);
1563   if (m != MATCH_NO)
1564     return m;
1565   m = match_out_tag (&tag_iostat, &open->iostat);
1566   if (m != MATCH_NO)
1567     return m;
1568   m = match_etag (&tag_file, &open->file);
1569   if (m != MATCH_NO)
1570     return m;
1571   m = match_etag (&tag_status, &open->status);
1572   if (m != MATCH_NO)
1573     return m;
1574   m = match_etag (&tag_e_access, &open->access);
1575   if (m != MATCH_NO)
1576     return m;
1577   m = match_etag (&tag_e_form, &open->form);
1578   if (m != MATCH_NO)
1579     return m;
1580   m = match_etag (&tag_e_recl, &open->recl);
1581   if (m != MATCH_NO)
1582     return m;
1583   m = match_etag (&tag_e_blank, &open->blank);
1584   if (m != MATCH_NO)
1585     return m;
1586   m = match_etag (&tag_e_position, &open->position);
1587   if (m != MATCH_NO)
1588     return m;
1589   m = match_etag (&tag_e_action, &open->action);
1590   if (m != MATCH_NO)
1591     return m;
1592   m = match_etag (&tag_e_delim, &open->delim);
1593   if (m != MATCH_NO)
1594     return m;
1595   m = match_etag (&tag_e_pad, &open->pad);
1596   if (m != MATCH_NO)
1597     return m;
1598   m = match_etag (&tag_e_decimal, &open->decimal);
1599   if (m != MATCH_NO)
1600     return m;
1601   m = match_etag (&tag_e_encoding, &open->encoding);
1602   if (m != MATCH_NO)
1603     return m;
1604   m = match_etag (&tag_e_round, &open->round);
1605   if (m != MATCH_NO)
1606     return m;
1607   m = match_etag (&tag_e_sign, &open->sign);
1608   if (m != MATCH_NO)
1609     return m;
1610   m = match_ltag (&tag_err, &open->err);
1611   if (m != MATCH_NO)
1612     return m;
1613   m = match_etag (&tag_convert, &open->convert);
1614   if (m != MATCH_NO)
1615     return m;
1616   m = match_out_tag (&tag_newunit, &open->newunit);
1617   if (m != MATCH_NO)
1618     return m;
1619
1620   return MATCH_NO;
1621 }
1622
1623
1624 /* Free the gfc_open structure and all the expressions it contains.  */
1625
1626 void
1627 gfc_free_open (gfc_open *open)
1628 {
1629   if (open == NULL)
1630     return;
1631
1632   gfc_free_expr (open->unit);
1633   gfc_free_expr (open->iomsg);
1634   gfc_free_expr (open->iostat);
1635   gfc_free_expr (open->file);
1636   gfc_free_expr (open->status);
1637   gfc_free_expr (open->access);
1638   gfc_free_expr (open->form);
1639   gfc_free_expr (open->recl);
1640   gfc_free_expr (open->blank);
1641   gfc_free_expr (open->position);
1642   gfc_free_expr (open->action);
1643   gfc_free_expr (open->delim);
1644   gfc_free_expr (open->pad);
1645   gfc_free_expr (open->decimal);
1646   gfc_free_expr (open->encoding);
1647   gfc_free_expr (open->round);
1648   gfc_free_expr (open->sign);
1649   gfc_free_expr (open->convert);
1650   gfc_free_expr (open->asynchronous);
1651   gfc_free_expr (open->newunit);
1652   free (open);
1653 }
1654
1655
1656 /* Resolve everything in a gfc_open structure.  */
1657
1658 gfc_try
1659 gfc_resolve_open (gfc_open *open)
1660 {
1661
1662   RESOLVE_TAG (&tag_unit, open->unit);
1663   RESOLVE_TAG (&tag_iomsg, open->iomsg);
1664   RESOLVE_TAG (&tag_iostat, open->iostat);
1665   RESOLVE_TAG (&tag_file, open->file);
1666   RESOLVE_TAG (&tag_status, open->status);
1667   RESOLVE_TAG (&tag_e_access, open->access);
1668   RESOLVE_TAG (&tag_e_form, open->form);
1669   RESOLVE_TAG (&tag_e_recl, open->recl);
1670   RESOLVE_TAG (&tag_e_blank, open->blank);
1671   RESOLVE_TAG (&tag_e_position, open->position);
1672   RESOLVE_TAG (&tag_e_action, open->action);
1673   RESOLVE_TAG (&tag_e_delim, open->delim);
1674   RESOLVE_TAG (&tag_e_pad, open->pad);
1675   RESOLVE_TAG (&tag_e_decimal, open->decimal);
1676   RESOLVE_TAG (&tag_e_encoding, open->encoding);
1677   RESOLVE_TAG (&tag_e_async, open->asynchronous);
1678   RESOLVE_TAG (&tag_e_round, open->round);
1679   RESOLVE_TAG (&tag_e_sign, open->sign);
1680   RESOLVE_TAG (&tag_convert, open->convert);
1681   RESOLVE_TAG (&tag_newunit, open->newunit);
1682
1683   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1684     return FAILURE;
1685
1686   return SUCCESS;
1687 }
1688
1689
1690 /* Check if a given value for a SPECIFIER is either in the list of values
1691    allowed in F95 or F2003, issuing an error message and returning a zero
1692    value if it is not allowed.  */
1693
1694 static int
1695 compare_to_allowed_values (const char *specifier, const char *allowed[],
1696                            const char *allowed_f2003[],
1697                            const char *allowed_gnu[], gfc_char_t *value,
1698                            const char *statement, bool warn)
1699 {
1700   int i;
1701   unsigned int len;
1702
1703   len = gfc_wide_strlen (value);
1704   if (len > 0)
1705   {
1706     for (len--; len > 0; len--)
1707       if (value[len] != ' ')
1708         break;
1709     len++;
1710   }
1711
1712   for (i = 0; allowed[i]; i++)
1713     if (len == strlen (allowed[i])
1714         && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1715       return 1;
1716
1717   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1718     if (len == strlen (allowed_f2003[i])
1719         && gfc_wide_strncasecmp (value, allowed_f2003[i],
1720                                  strlen (allowed_f2003[i])) == 0)
1721       {
1722         notification n = gfc_notification_std (GFC_STD_F2003);
1723
1724         if (n == WARNING || (warn && n == ERROR))
1725           {
1726             gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1727                          "has value '%s'", specifier, statement,
1728                          allowed_f2003[i]);
1729             return 1;
1730           }
1731         else
1732           if (n == ERROR)
1733             {
1734               gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1735                               "%s statement at %C has value '%s'", specifier,
1736                               statement, allowed_f2003[i]);
1737               return 0;
1738             }
1739
1740         /* n == SILENT */
1741         return 1;
1742       }
1743
1744   for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1745     if (len == strlen (allowed_gnu[i])
1746         && gfc_wide_strncasecmp (value, allowed_gnu[i],
1747                                  strlen (allowed_gnu[i])) == 0)
1748       {
1749         notification n = gfc_notification_std (GFC_STD_GNU);
1750
1751         if (n == WARNING || (warn && n == ERROR))
1752           {
1753             gfc_warning ("Extension: %s specifier in %s statement at %C "
1754                          "has value '%s'", specifier, statement,
1755                          allowed_gnu[i]);
1756             return 1;
1757           }
1758         else
1759           if (n == ERROR)
1760             {
1761               gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1762                               "%s statement at %C has value '%s'", specifier,
1763                               statement, allowed_gnu[i]);
1764               return 0;
1765             }
1766
1767         /* n == SILENT */
1768         return 1;
1769       }
1770
1771   if (warn)
1772     {
1773       char *s = gfc_widechar_to_char (value, -1);
1774       gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1775                    specifier, statement, s);
1776       free (s);
1777       return 1;
1778     }
1779   else
1780     {
1781       char *s = gfc_widechar_to_char (value, -1);
1782       gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1783                  specifier, statement, s);
1784       free (s);
1785       return 0;
1786     }
1787 }
1788
1789
1790 /* Match an OPEN statement.  */
1791
1792 match
1793 gfc_match_open (void)
1794 {
1795   gfc_open *open;
1796   match m;
1797   bool warn;
1798
1799   m = gfc_match_char ('(');
1800   if (m == MATCH_NO)
1801     return m;
1802
1803   open = XCNEW (gfc_open);
1804
1805   m = match_open_element (open);
1806
1807   if (m == MATCH_ERROR)
1808     goto cleanup;
1809   if (m == MATCH_NO)
1810     {
1811       m = gfc_match_expr (&open->unit);
1812       if (m == MATCH_ERROR)
1813         goto cleanup;
1814     }
1815
1816   for (;;)
1817     {
1818       if (gfc_match_char (')') == MATCH_YES)
1819         break;
1820       if (gfc_match_char (',') != MATCH_YES)
1821         goto syntax;
1822
1823       m = match_open_element (open);
1824       if (m == MATCH_ERROR)
1825         goto cleanup;
1826       if (m == MATCH_NO)
1827         goto syntax;
1828     }
1829
1830   if (gfc_match_eos () == MATCH_NO)
1831     goto syntax;
1832
1833   if (gfc_pure (NULL))
1834     {
1835       gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1836       goto cleanup;
1837     }
1838
1839   if (gfc_implicit_pure (NULL))
1840     gfc_current_ns->proc_name->attr.implicit_pure = 0;
1841
1842   warn = (open->err || open->iostat) ? true : false;
1843
1844   /* Checks on NEWUNIT specifier.  */
1845   if (open->newunit)
1846     {
1847       if (open->unit)
1848         {
1849           gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1850           goto cleanup;
1851         }
1852
1853       if (!(open->file || (open->status
1854           && gfc_wide_strncasecmp (open->status->value.character.string,
1855                                    "scratch", 7) == 0)))
1856         {
1857           gfc_error ("NEWUNIT specifier must have FILE= "
1858                      "or STATUS='scratch' at %C");
1859           goto cleanup;
1860         }
1861     }
1862   else if (!open->unit)
1863     {
1864       gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1865       goto cleanup;
1866     }
1867
1868   /* Checks on the ACCESS specifier.  */
1869   if (open->access && open->access->expr_type == EXPR_CONSTANT)
1870     {
1871       static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1872       static const char *access_f2003[] = { "STREAM", NULL };
1873       static const char *access_gnu[] = { "APPEND", NULL };
1874
1875       if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1876                                       access_gnu,
1877                                       open->access->value.character.string,
1878                                       "OPEN", warn))
1879         goto cleanup;
1880     }
1881
1882   /* Checks on the ACTION specifier.  */
1883   if (open->action && open->action->expr_type == EXPR_CONSTANT)
1884     {
1885       static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1886
1887       if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1888                                       open->action->value.character.string,
1889                                       "OPEN", warn))
1890         goto cleanup;
1891     }
1892
1893   /* Checks on the ASYNCHRONOUS specifier.  */
1894   if (open->asynchronous)
1895     {
1896       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
1897           "not allowed in Fortran 95") == FAILURE)
1898         goto cleanup;
1899
1900       if (open->asynchronous->expr_type == EXPR_CONSTANT)
1901         {
1902           static const char * asynchronous[] = { "YES", "NO", NULL };
1903
1904           if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1905                         NULL, NULL, open->asynchronous->value.character.string,
1906                         "OPEN", warn))
1907             goto cleanup;
1908         }
1909     }
1910
1911   /* Checks on the BLANK specifier.  */
1912   if (open->blank)
1913     {
1914       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
1915           "not allowed in Fortran 95") == FAILURE)
1916         goto cleanup;
1917
1918       if (open->blank->expr_type == EXPR_CONSTANT)
1919         {
1920           static const char *blank[] = { "ZERO", "NULL", NULL };
1921
1922           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1923                                           open->blank->value.character.string,
1924                                           "OPEN", warn))
1925             goto cleanup;
1926         }
1927     }
1928
1929   /* Checks on the DECIMAL specifier.  */
1930   if (open->decimal)
1931     {
1932       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
1933           "not allowed in Fortran 95") == FAILURE)
1934         goto cleanup;
1935
1936       if (open->decimal->expr_type == EXPR_CONSTANT)
1937         {
1938           static const char * decimal[] = { "COMMA", "POINT", NULL };
1939
1940           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1941                                           open->decimal->value.character.string,
1942                                           "OPEN", warn))
1943             goto cleanup;
1944         }
1945     }
1946
1947   /* Checks on the DELIM specifier.  */
1948   if (open->delim)
1949     {
1950       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1951           "not allowed in Fortran 95") == FAILURE)
1952         goto cleanup;
1953
1954       if (open->delim->expr_type == EXPR_CONSTANT)
1955         {
1956           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1957
1958           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1959                                           open->delim->value.character.string,
1960                                           "OPEN", warn))
1961           goto cleanup;
1962         }
1963     }
1964
1965   /* Checks on the ENCODING specifier.  */
1966   if (open->encoding)
1967     {
1968       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1969           "not allowed in Fortran 95") == FAILURE)
1970         goto cleanup;
1971
1972       if (open->encoding->expr_type == EXPR_CONSTANT)
1973         {
1974           static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1975
1976           if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1977                                           open->encoding->value.character.string,
1978                                           "OPEN", warn))
1979           goto cleanup;
1980         }
1981     }
1982
1983   /* Checks on the FORM specifier.  */
1984   if (open->form && open->form->expr_type == EXPR_CONSTANT)
1985     {
1986       static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1987
1988       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1989                                       open->form->value.character.string,
1990                                       "OPEN", warn))
1991         goto cleanup;
1992     }
1993
1994   /* Checks on the PAD specifier.  */
1995   if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1996     {
1997       static const char *pad[] = { "YES", "NO", NULL };
1998
1999       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
2000                                       open->pad->value.character.string,
2001                                       "OPEN", warn))
2002         goto cleanup;
2003     }
2004
2005   /* Checks on the POSITION specifier.  */
2006   if (open->position && open->position->expr_type == EXPR_CONSTANT)
2007     {
2008       static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
2009
2010       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2011                                       open->position->value.character.string,
2012                                       "OPEN", warn))
2013         goto cleanup;
2014     }
2015
2016   /* Checks on the ROUND specifier.  */
2017   if (open->round)
2018     {
2019       if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
2020           "not allowed in Fortran 95") == FAILURE)
2021       goto cleanup;
2022
2023       if (open->round->expr_type == EXPR_CONSTANT)
2024         {
2025           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2026                                           "COMPATIBLE", "PROCESSOR_DEFINED",
2027                                            NULL };
2028
2029           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2030                                           open->round->value.character.string,
2031                                           "OPEN", warn))
2032           goto cleanup;
2033         }
2034     }
2035
2036   /* Checks on the SIGN specifier.  */
2037   if (open->sign)
2038     {
2039       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
2040           "not allowed in Fortran 95") == FAILURE)
2041         goto cleanup;
2042
2043       if (open->sign->expr_type == EXPR_CONSTANT)
2044         {
2045           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2046                                           NULL };
2047
2048           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2049                                           open->sign->value.character.string,
2050                                           "OPEN", warn))
2051           goto cleanup;
2052         }
2053     }
2054
2055 #define warn_or_error(...) \
2056 { \
2057   if (warn) \
2058     gfc_warning (__VA_ARGS__); \
2059   else \
2060     { \
2061       gfc_error (__VA_ARGS__); \
2062       goto cleanup; \
2063     } \
2064 }
2065
2066   /* Checks on the RECL specifier.  */
2067   if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2068       && open->recl->ts.type == BT_INTEGER
2069       && mpz_sgn (open->recl->value.integer) != 1)
2070     {
2071       warn_or_error ("RECL in OPEN statement at %C must be positive");
2072     }
2073
2074   /* Checks on the STATUS specifier.  */
2075   if (open->status && open->status->expr_type == EXPR_CONSTANT)
2076     {
2077       static const char *status[] = { "OLD", "NEW", "SCRATCH",
2078         "REPLACE", "UNKNOWN", NULL };
2079
2080       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2081                                       open->status->value.character.string,
2082                                       "OPEN", warn))
2083         goto cleanup;
2084
2085       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2086          the FILE= specifier shall appear.  */
2087       if (open->file == NULL
2088           && (gfc_wide_strncasecmp (open->status->value.character.string,
2089                                     "replace", 7) == 0
2090               || gfc_wide_strncasecmp (open->status->value.character.string,
2091                                        "new", 3) == 0))
2092         {
2093           char *s = gfc_widechar_to_char (open->status->value.character.string,
2094                                           -1);
2095           warn_or_error ("The STATUS specified in OPEN statement at %C is "
2096                          "'%s' and no FILE specifier is present", s);
2097           free (s);
2098         }
2099
2100       /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2101          the FILE= specifier shall not appear.  */
2102       if (gfc_wide_strncasecmp (open->status->value.character.string,
2103                                 "scratch", 7) == 0 && open->file)
2104         {
2105           warn_or_error ("The STATUS specified in OPEN statement at %C "
2106                          "cannot have the value SCRATCH if a FILE specifier "
2107                          "is present");
2108         }
2109     }
2110
2111   /* Things that are not allowed for unformatted I/O.  */
2112   if (open->form && open->form->expr_type == EXPR_CONSTANT
2113       && (open->delim || open->decimal || open->encoding || open->round
2114           || open->sign || open->pad || open->blank)
2115       && gfc_wide_strncasecmp (open->form->value.character.string,
2116                                "unformatted", 11) == 0)
2117     {
2118       const char *spec = (open->delim ? "DELIM "
2119                                       : (open->pad ? "PAD " : open->blank
2120                                                             ? "BLANK " : ""));
2121
2122       warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2123                      "unformatted I/O", spec);
2124     }
2125
2126   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2127       && gfc_wide_strncasecmp (open->access->value.character.string,
2128                                "stream", 6) == 0)
2129     {
2130       warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2131                      "stream I/O");
2132     }
2133
2134   if (open->position
2135       && open->access && open->access->expr_type == EXPR_CONSTANT
2136       && !(gfc_wide_strncasecmp (open->access->value.character.string,
2137                                  "sequential", 10) == 0
2138            || gfc_wide_strncasecmp (open->access->value.character.string,
2139                                     "stream", 6) == 0
2140            || gfc_wide_strncasecmp (open->access->value.character.string,
2141                                     "append", 6) == 0))
2142     {
2143       warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2144                      "for stream or sequential ACCESS");
2145     }
2146
2147 #undef warn_or_error
2148
2149   new_st.op = EXEC_OPEN;
2150   new_st.ext.open = open;
2151   return MATCH_YES;
2152
2153 syntax:
2154   gfc_syntax_error (ST_OPEN);
2155
2156 cleanup:
2157   gfc_free_open (open);
2158   return MATCH_ERROR;
2159 }
2160
2161
2162 /* Free a gfc_close structure an all its expressions.  */
2163
2164 void
2165 gfc_free_close (gfc_close *close)
2166 {
2167   if (close == NULL)
2168     return;
2169
2170   gfc_free_expr (close->unit);
2171   gfc_free_expr (close->iomsg);
2172   gfc_free_expr (close->iostat);
2173   gfc_free_expr (close->status);
2174   free (close);
2175 }
2176
2177
2178 /* Match elements of a CLOSE statement.  */
2179
2180 static match
2181 match_close_element (gfc_close *close)
2182 {
2183   match m;
2184
2185   m = match_etag (&tag_unit, &close->unit);
2186   if (m != MATCH_NO)
2187     return m;
2188   m = match_etag (&tag_status, &close->status);
2189   if (m != MATCH_NO)
2190     return m;
2191   m = match_out_tag (&tag_iomsg, &close->iomsg);
2192   if (m != MATCH_NO)
2193     return m;
2194   m = match_out_tag (&tag_iostat, &close->iostat);
2195   if (m != MATCH_NO)
2196     return m;
2197   m = match_ltag (&tag_err, &close->err);
2198   if (m != MATCH_NO)
2199     return m;
2200
2201   return MATCH_NO;
2202 }
2203
2204
2205 /* Match a CLOSE statement.  */
2206
2207 match
2208 gfc_match_close (void)
2209 {
2210   gfc_close *close;
2211   match m;
2212   bool warn;
2213
2214   m = gfc_match_char ('(');
2215   if (m == MATCH_NO)
2216     return m;
2217
2218   close = XCNEW (gfc_close);
2219
2220   m = match_close_element (close);
2221
2222   if (m == MATCH_ERROR)
2223     goto cleanup;
2224   if (m == MATCH_NO)
2225     {
2226       m = gfc_match_expr (&close->unit);
2227       if (m == MATCH_NO)
2228         goto syntax;
2229       if (m == MATCH_ERROR)
2230         goto cleanup;
2231     }
2232
2233   for (;;)
2234     {
2235       if (gfc_match_char (')') == MATCH_YES)
2236         break;
2237       if (gfc_match_char (',') != MATCH_YES)
2238         goto syntax;
2239
2240       m = match_close_element (close);
2241       if (m == MATCH_ERROR)
2242         goto cleanup;
2243       if (m == MATCH_NO)
2244         goto syntax;
2245     }
2246
2247   if (gfc_match_eos () == MATCH_NO)
2248     goto syntax;
2249
2250   if (gfc_pure (NULL))
2251     {
2252       gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2253       goto cleanup;
2254     }
2255
2256   if (gfc_implicit_pure (NULL))
2257     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2258
2259   warn = (close->iostat || close->err) ? true : false;
2260
2261   /* Checks on the STATUS specifier.  */
2262   if (close->status && close->status->expr_type == EXPR_CONSTANT)
2263     {
2264       static const char *status[] = { "KEEP", "DELETE", NULL };
2265
2266       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2267                                       close->status->value.character.string,
2268                                       "CLOSE", warn))
2269         goto cleanup;
2270     }
2271
2272   new_st.op = EXEC_CLOSE;
2273   new_st.ext.close = close;
2274   return MATCH_YES;
2275
2276 syntax:
2277   gfc_syntax_error (ST_CLOSE);
2278
2279 cleanup:
2280   gfc_free_close (close);
2281   return MATCH_ERROR;
2282 }
2283
2284
2285 /* Resolve everything in a gfc_close structure.  */
2286
2287 gfc_try
2288 gfc_resolve_close (gfc_close *close)
2289 {
2290   RESOLVE_TAG (&tag_unit, close->unit);
2291   RESOLVE_TAG (&tag_iomsg, close->iomsg);
2292   RESOLVE_TAG (&tag_iostat, close->iostat);
2293   RESOLVE_TAG (&tag_status, close->status);
2294
2295   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2296     return FAILURE;
2297
2298   if (close->unit->expr_type == EXPR_CONSTANT
2299       && close->unit->ts.type == BT_INTEGER
2300       && mpz_sgn (close->unit->value.integer) < 0)
2301     {
2302       gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2303                  &close->unit->where);
2304     }
2305
2306   return SUCCESS;
2307 }
2308
2309
2310 /* Free a gfc_filepos structure.  */
2311
2312 void
2313 gfc_free_filepos (gfc_filepos *fp)
2314 {
2315   gfc_free_expr (fp->unit);
2316   gfc_free_expr (fp->iomsg);
2317   gfc_free_expr (fp->iostat);
2318   free (fp);
2319 }
2320
2321
2322 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
2323
2324 static match
2325 match_file_element (gfc_filepos *fp)
2326 {
2327   match m;
2328
2329   m = match_etag (&tag_unit, &fp->unit);
2330   if (m != MATCH_NO)
2331     return m;
2332   m = match_out_tag (&tag_iomsg, &fp->iomsg);
2333   if (m != MATCH_NO)
2334     return m;
2335   m = match_out_tag (&tag_iostat, &fp->iostat);
2336   if (m != MATCH_NO)
2337     return m;
2338   m = match_ltag (&tag_err, &fp->err);
2339   if (m != MATCH_NO)
2340     return m;
2341
2342   return MATCH_NO;
2343 }
2344
2345
2346 /* Match the second half of the file-positioning statements, REWIND,
2347    BACKSPACE, ENDFILE, or the FLUSH statement.  */
2348
2349 static match
2350 match_filepos (gfc_statement st, gfc_exec_op op)
2351 {
2352   gfc_filepos *fp;
2353   match m;
2354
2355   fp = XCNEW (gfc_filepos);
2356
2357   if (gfc_match_char ('(') == MATCH_NO)
2358     {
2359       m = gfc_match_expr (&fp->unit);
2360       if (m == MATCH_ERROR)
2361         goto cleanup;
2362       if (m == MATCH_NO)
2363         goto syntax;
2364
2365       goto done;
2366     }
2367
2368   m = match_file_element (fp);
2369   if (m == MATCH_ERROR)
2370     goto done;
2371   if (m == MATCH_NO)
2372     {
2373       m = gfc_match_expr (&fp->unit);
2374       if (m == MATCH_ERROR)
2375         goto done;
2376       if (m == MATCH_NO)
2377         goto syntax;
2378     }
2379
2380   for (;;)
2381     {
2382       if (gfc_match_char (')') == MATCH_YES)
2383         break;
2384       if (gfc_match_char (',') != MATCH_YES)
2385         goto syntax;
2386
2387       m = match_file_element (fp);
2388       if (m == MATCH_ERROR)
2389         goto cleanup;
2390       if (m == MATCH_NO)
2391         goto syntax;
2392     }
2393
2394 done:
2395   if (gfc_match_eos () != MATCH_YES)
2396     goto syntax;
2397
2398   if (gfc_pure (NULL))
2399     {
2400       gfc_error ("%s statement not allowed in PURE procedure at %C",
2401                  gfc_ascii_statement (st));
2402
2403       goto cleanup;
2404     }
2405
2406   if (gfc_implicit_pure (NULL))
2407     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2408
2409   new_st.op = op;
2410   new_st.ext.filepos = fp;
2411   return MATCH_YES;
2412
2413 syntax:
2414   gfc_syntax_error (st);
2415
2416 cleanup:
2417   gfc_free_filepos (fp);
2418   return MATCH_ERROR;
2419 }
2420
2421
2422 gfc_try
2423 gfc_resolve_filepos (gfc_filepos *fp)
2424 {
2425   RESOLVE_TAG (&tag_unit, fp->unit);
2426   RESOLVE_TAG (&tag_iostat, fp->iostat);
2427   RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2428   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2429     return FAILURE;
2430
2431   if (fp->unit->expr_type == EXPR_CONSTANT
2432       && fp->unit->ts.type == BT_INTEGER
2433       && mpz_sgn (fp->unit->value.integer) < 0)
2434     {
2435       gfc_error ("UNIT number in statement at %L must be non-negative",
2436                  &fp->unit->where);
2437     }
2438
2439   return SUCCESS;
2440 }
2441
2442
2443 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2444    and the FLUSH statement.  */
2445
2446 match
2447 gfc_match_endfile (void)
2448 {
2449   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2450 }
2451
2452 match
2453 gfc_match_backspace (void)
2454 {
2455   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2456 }
2457
2458 match
2459 gfc_match_rewind (void)
2460 {
2461   return match_filepos (ST_REWIND, EXEC_REWIND);
2462 }
2463
2464 match
2465 gfc_match_flush (void)
2466 {
2467   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2468       == FAILURE)
2469     return MATCH_ERROR;
2470
2471   return match_filepos (ST_FLUSH, EXEC_FLUSH);
2472 }
2473
2474 /******************** Data Transfer Statements *********************/
2475
2476 /* Return a default unit number.  */
2477
2478 static gfc_expr *
2479 default_unit (io_kind k)
2480 {
2481   int unit;
2482
2483   if (k == M_READ)
2484     unit = 5;
2485   else
2486     unit = 6;
2487
2488   return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2489 }
2490
2491
2492 /* Match a unit specification for a data transfer statement.  */
2493
2494 static match
2495 match_dt_unit (io_kind k, gfc_dt *dt)
2496 {
2497   gfc_expr *e;
2498
2499   if (gfc_match_char ('*') == MATCH_YES)
2500     {
2501       if (dt->io_unit != NULL)
2502         goto conflict;
2503
2504       dt->io_unit = default_unit (k);
2505       return MATCH_YES;
2506     }
2507
2508   if (gfc_match_expr (&e) == MATCH_YES)
2509     {
2510       if (dt->io_unit != NULL)
2511         {
2512           gfc_free_expr (e);
2513           goto conflict;
2514         }
2515
2516       dt->io_unit = e;
2517       return MATCH_YES;
2518     }
2519
2520   return MATCH_NO;
2521
2522 conflict:
2523   gfc_error ("Duplicate UNIT specification at %C");
2524   return MATCH_ERROR;
2525 }
2526
2527
2528 /* Match a format specification.  */
2529
2530 static match
2531 match_dt_format (gfc_dt *dt)
2532 {
2533   locus where;
2534   gfc_expr *e;
2535   gfc_st_label *label;
2536   match m;
2537
2538   where = gfc_current_locus;
2539
2540   if (gfc_match_char ('*') == MATCH_YES)
2541     {
2542       if (dt->format_expr != NULL || dt->format_label != NULL)
2543         goto conflict;
2544
2545       dt->format_label = &format_asterisk;
2546       return MATCH_YES;
2547     }
2548
2549   if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2550     {
2551       if (dt->format_expr != NULL || dt->format_label != NULL)
2552         {
2553           gfc_free_st_label (label);
2554           goto conflict;
2555         }
2556
2557       if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2558         return MATCH_ERROR;
2559
2560       dt->format_label = label;
2561       return MATCH_YES;
2562     }
2563   else if (m == MATCH_ERROR)
2564     /* The label was zero or too large.  Emit the correct diagnosis.  */
2565     return MATCH_ERROR;
2566
2567   if (gfc_match_expr (&e) == MATCH_YES)
2568     {
2569       if (dt->format_expr != NULL || dt->format_label != NULL)
2570         {
2571           gfc_free_expr (e);
2572           goto conflict;
2573         }
2574       dt->format_expr = e;
2575       return MATCH_YES;
2576     }
2577
2578   gfc_current_locus = where;    /* The only case where we have to restore */
2579
2580   return MATCH_NO;
2581
2582 conflict:
2583   gfc_error ("Duplicate format specification at %C");
2584   return MATCH_ERROR;
2585 }
2586
2587
2588 /* Traverse a namelist that is part of a READ statement to make sure
2589    that none of the variables in the namelist are INTENT(IN).  Returns
2590    nonzero if we find such a variable.  */
2591
2592 static int
2593 check_namelist (gfc_symbol *sym)
2594 {
2595   gfc_namelist *p;
2596
2597   for (p = sym->namelist; p; p = p->next)
2598     if (p->sym->attr.intent == INTENT_IN)
2599       {
2600         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2601                    p->sym->name, sym->name);
2602         return 1;
2603       }
2604
2605   return 0;
2606 }
2607
2608
2609 /* Match a single data transfer element.  */
2610
2611 static match
2612 match_dt_element (io_kind k, gfc_dt *dt)
2613 {
2614   char name[GFC_MAX_SYMBOL_LEN + 1];
2615   gfc_symbol *sym;
2616   match m;
2617
2618   if (gfc_match (" unit =") == MATCH_YES)
2619     {
2620       m = match_dt_unit (k, dt);
2621       if (m != MATCH_NO)
2622         return m;
2623     }
2624
2625   if (gfc_match (" fmt =") == MATCH_YES)
2626     {
2627       m = match_dt_format (dt);
2628       if (m != MATCH_NO)
2629         return m;
2630     }
2631
2632   if (gfc_match (" nml = %n", name) == MATCH_YES)
2633     {
2634       if (dt->namelist != NULL)
2635         {
2636           gfc_error ("Duplicate NML specification at %C");
2637           return MATCH_ERROR;
2638         }
2639
2640       if (gfc_find_symbol (name, NULL, 1, &sym))
2641         return MATCH_ERROR;
2642
2643       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2644         {
2645           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2646                      sym != NULL ? sym->name : name);
2647           return MATCH_ERROR;
2648         }
2649
2650       dt->namelist = sym;
2651       if (k == M_READ && check_namelist (sym))
2652         return MATCH_ERROR;
2653
2654       return MATCH_YES;
2655     }
2656
2657   m = match_etag (&tag_e_async, &dt->asynchronous);
2658   if (m != MATCH_NO)
2659     return m;
2660   m = match_etag (&tag_e_blank, &dt->blank);
2661   if (m != MATCH_NO)
2662     return m;
2663   m = match_etag (&tag_e_delim, &dt->delim);
2664   if (m != MATCH_NO)
2665     return m;
2666   m = match_etag (&tag_e_pad, &dt->pad);
2667   if (m != MATCH_NO)
2668     return m;
2669   m = match_etag (&tag_e_sign, &dt->sign);
2670   if (m != MATCH_NO)
2671     return m;
2672   m = match_etag (&tag_e_round, &dt->round);
2673   if (m != MATCH_NO)
2674     return m;
2675   m = match_out_tag (&tag_id, &dt->id);
2676   if (m != MATCH_NO)
2677     return m;
2678   m = match_etag (&tag_e_decimal, &dt->decimal);
2679   if (m != MATCH_NO)
2680     return m;
2681   m = match_etag (&tag_rec, &dt->rec);
2682   if (m != MATCH_NO)
2683     return m;
2684   m = match_etag (&tag_spos, &dt->pos);
2685   if (m != MATCH_NO)
2686     return m;
2687   m = match_out_tag (&tag_iomsg, &dt->iomsg);
2688   if (m != MATCH_NO)
2689     return m;
2690   m = match_out_tag (&tag_iostat, &dt->iostat);
2691   if (m != MATCH_NO)
2692     return m;
2693   m = match_ltag (&tag_err, &dt->err);
2694   if (m == MATCH_YES)
2695     dt->err_where = gfc_current_locus;
2696   if (m != MATCH_NO)
2697     return m;
2698   m = match_etag (&tag_advance, &dt->advance);
2699   if (m != MATCH_NO)
2700     return m;
2701   m = match_out_tag (&tag_size, &dt->size);
2702   if (m != MATCH_NO)
2703     return m;
2704
2705   m = match_ltag (&tag_end, &dt->end);
2706   if (m == MATCH_YES)
2707     {
2708       if (k == M_WRITE)
2709        {
2710          gfc_error ("END tag at %C not allowed in output statement");
2711          return MATCH_ERROR;
2712        }
2713       dt->end_where = gfc_current_locus;
2714     }
2715   if (m != MATCH_NO)
2716     return m;
2717
2718   m = match_ltag (&tag_eor, &dt->eor);
2719   if (m == MATCH_YES)
2720     dt->eor_where = gfc_current_locus;
2721   if (m != MATCH_NO)
2722     return m;
2723
2724   return MATCH_NO;
2725 }
2726
2727
2728 /* Free a data transfer structure and everything below it.  */
2729
2730 void
2731 gfc_free_dt (gfc_dt *dt)
2732 {
2733   if (dt == NULL)
2734     return;
2735
2736   gfc_free_expr (dt->io_unit);
2737   gfc_free_expr (dt->format_expr);
2738   gfc_free_expr (dt->rec);
2739   gfc_free_expr (dt->advance);
2740   gfc_free_expr (dt->iomsg);
2741   gfc_free_expr (dt->iostat);
2742   gfc_free_expr (dt->size);
2743   gfc_free_expr (dt->pad);
2744   gfc_free_expr (dt->delim);
2745   gfc_free_expr (dt->sign);
2746   gfc_free_expr (dt->round);
2747   gfc_free_expr (dt->blank);
2748   gfc_free_expr (dt->decimal);
2749   gfc_free_expr (dt->pos);
2750   gfc_free_expr (dt->dt_io_kind);
2751   /* dt->extra_comma is a link to dt_io_kind if it is set.  */
2752   free (dt);
2753 }
2754
2755
2756 /* Resolve everything in a gfc_dt structure.  */
2757
2758 gfc_try
2759 gfc_resolve_dt (gfc_dt *dt, locus *loc)
2760 {
2761   gfc_expr *e;
2762   io_kind k;
2763
2764   /* This is set in any case.  */
2765   gcc_assert (dt->dt_io_kind);
2766   k = dt->dt_io_kind->value.iokind;
2767
2768   RESOLVE_TAG (&tag_format, dt->format_expr);
2769   RESOLVE_TAG (&tag_rec, dt->rec);
2770   RESOLVE_TAG (&tag_spos, dt->pos);
2771   RESOLVE_TAG (&tag_advance, dt->advance);
2772   RESOLVE_TAG (&tag_id, dt->id);
2773   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2774   RESOLVE_TAG (&tag_iostat, dt->iostat);
2775   RESOLVE_TAG (&tag_size, dt->size);
2776   RESOLVE_TAG (&tag_e_pad, dt->pad);
2777   RESOLVE_TAG (&tag_e_delim, dt->delim);
2778   RESOLVE_TAG (&tag_e_sign, dt->sign);
2779   RESOLVE_TAG (&tag_e_round, dt->round);
2780   RESOLVE_TAG (&tag_e_blank, dt->blank);
2781   RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2782   RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2783
2784   e = dt->io_unit;
2785   if (e == NULL)
2786     {
2787       gfc_error ("UNIT not specified at %L", loc);
2788       return FAILURE;
2789     }
2790
2791   if (gfc_resolve_expr (e) == SUCCESS
2792       && (e->ts.type != BT_INTEGER
2793           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2794     {
2795       /* If there is no extra comma signifying the "format" form of the IO
2796          statement, then this must be an error.  */
2797       if (!dt->extra_comma)
2798         {
2799           gfc_error ("UNIT specification at %L must be an INTEGER expression "
2800                      "or a CHARACTER variable", &e->where);
2801           return FAILURE;
2802         }
2803       else
2804         {
2805           /* At this point, we have an extra comma.  If io_unit has arrived as
2806              type character, we assume its really the "format" form of the I/O
2807              statement.  We set the io_unit to the default unit and format to
2808              the character expression.  See F95 Standard section 9.4.  */
2809           if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2810             {
2811               dt->format_expr = dt->io_unit;
2812               dt->io_unit = default_unit (k);
2813
2814               /* Nullify this pointer now so that a warning/error is not
2815                  triggered below for the "Extension".  */
2816               dt->extra_comma = NULL;
2817             }
2818
2819           if (k == M_WRITE)
2820             {
2821               gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2822                          &dt->extra_comma->where);
2823               return FAILURE;
2824             }
2825         }
2826     }
2827
2828   if (e->ts.type == BT_CHARACTER)
2829     {
2830       if (gfc_has_vector_index (e))
2831         {
2832           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2833           return FAILURE;
2834         }
2835
2836       /* If we are writing, make sure the internal unit can be changed.  */
2837       gcc_assert (k != M_PRINT);
2838       if (k == M_WRITE
2839           && gfc_check_vardef_context (e, false, false,
2840                                        _("internal unit in WRITE")) == FAILURE)
2841         return FAILURE;
2842     }
2843
2844   if (e->rank && e->ts.type != BT_CHARACTER)
2845     {
2846       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2847       return FAILURE;
2848     }
2849
2850   if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2851       && mpz_sgn (e->value.integer) < 0)
2852     {
2853       gfc_error ("UNIT number in statement at %L must be non-negative",
2854                  &e->where);
2855       return FAILURE;
2856     }
2857
2858   /* If we are reading and have a namelist, check that all namelist symbols
2859      can appear in a variable definition context.  */
2860   if (k == M_READ && dt->namelist)
2861     {
2862       gfc_namelist* n;
2863       for (n = dt->namelist->namelist; n; n = n->next)
2864         {
2865           gfc_expr* e;
2866           gfc_try t;
2867
2868           e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
2869           t = gfc_check_vardef_context (e, false, false, NULL);
2870           gfc_free_expr (e);
2871
2872           if (t == FAILURE)
2873             {
2874               gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2875                          " the symbol '%s' which may not appear in a"
2876                          " variable definition context",
2877                          dt->namelist->name, loc, n->sym->name);
2878               return FAILURE;
2879             }
2880         }
2881     }
2882
2883   if (dt->extra_comma
2884       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2885                          "item list at %L", &dt->extra_comma->where) == FAILURE)
2886     return FAILURE;
2887
2888   if (dt->err)
2889     {
2890       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2891         return FAILURE;
2892       if (dt->err->defined == ST_LABEL_UNKNOWN)
2893         {
2894           gfc_error ("ERR tag label %d at %L not defined",
2895                       dt->err->value, &dt->err_where);
2896           return FAILURE;
2897         }
2898     }
2899
2900   if (dt->end)
2901     {
2902       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2903         return FAILURE;
2904       if (dt->end->defined == ST_LABEL_UNKNOWN)
2905         {
2906           gfc_error ("END tag label %d at %L not defined",
2907                       dt->end->value, &dt->end_where);
2908           return FAILURE;
2909         }
2910     }
2911
2912   if (dt->eor)
2913     {
2914       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2915         return FAILURE;
2916       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2917         {
2918           gfc_error ("EOR tag label %d at %L not defined",
2919                       dt->eor->value, &dt->eor_where);
2920           return FAILURE;
2921         }
2922     }
2923
2924   /* Check the format label actually exists.  */
2925   if (dt->format_label && dt->format_label != &format_asterisk
2926       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2927     {
2928       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2929                  &dt->format_label->where);
2930       return FAILURE;
2931     }
2932
2933   return SUCCESS;
2934 }
2935
2936
2937 /* Given an io_kind, return its name.  */
2938
2939 static const char *
2940 io_kind_name (io_kind k)
2941 {
2942   const char *name;
2943
2944   switch (k)
2945     {
2946     case M_READ:
2947       name = "READ";
2948       break;
2949     case M_WRITE:
2950       name = "WRITE";
2951       break;
2952     case M_PRINT:
2953       name = "PRINT";
2954       break;
2955     case M_INQUIRE:
2956       name = "INQUIRE";
2957       break;
2958     default:
2959       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2960     }
2961
2962   return name;
2963 }
2964
2965
2966 /* Match an IO iteration statement of the form:
2967
2968    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2969
2970    which is equivalent to a single IO element.  This function is
2971    mutually recursive with match_io_element().  */
2972
2973 static match match_io_element (io_kind, gfc_code **);
2974
2975 static match
2976 match_io_iterator (io_kind k, gfc_code **result)
2977 {
2978   gfc_code *head, *tail, *new_code;
2979   gfc_iterator *iter;
2980   locus old_loc;
2981   match m;
2982   int n;
2983
2984   iter = NULL;
2985   head = NULL;
2986   old_loc = gfc_current_locus;
2987
2988   if (gfc_match_char ('(') != MATCH_YES)
2989     return MATCH_NO;
2990
2991   m = match_io_element (k, &head);
2992   tail = head;
2993
2994   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2995     {
2996       m = MATCH_NO;
2997       goto cleanup;
2998     }
2999
3000   /* Can't be anything but an IO iterator.  Build a list.  */
3001   iter = gfc_get_iterator ();
3002
3003   for (n = 1;; n++)
3004     {
3005       m = gfc_match_iterator (iter, 0);
3006       if (m == MATCH_ERROR)
3007         goto cleanup;
3008       if (m == MATCH_YES)
3009         {
3010           gfc_check_do_variable (iter->var->symtree);
3011           break;
3012         }
3013
3014       m = match_io_element (k, &new_code);
3015       if (m == MATCH_ERROR)
3016         goto cleanup;
3017       if (m == MATCH_NO)
3018         {
3019           if (n > 2)
3020             goto syntax;
3021           goto cleanup;
3022         }
3023
3024       tail = gfc_append_code (tail, new_code);
3025
3026       if (gfc_match_char (',') != MATCH_YES)
3027         {
3028           if (n > 2)
3029             goto syntax;
3030           m = MATCH_NO;
3031           goto cleanup;
3032         }
3033     }
3034
3035   if (gfc_match_char (')') != MATCH_YES)
3036     goto syntax;
3037
3038   new_code = gfc_get_code ();
3039   new_code->op = EXEC_DO;
3040   new_code->ext.iterator = iter;
3041
3042   new_code->block = gfc_get_code ();
3043   new_code->block->op = EXEC_DO;
3044   new_code->block->next = head;
3045
3046   *result = new_code;
3047   return MATCH_YES;
3048
3049 syntax:
3050   gfc_error ("Syntax error in I/O iterator at %C");
3051   m = MATCH_ERROR;
3052
3053 cleanup:
3054   gfc_free_iterator (iter, 1);
3055   gfc_free_statements (head);
3056   gfc_current_locus = old_loc;
3057   return m;
3058 }
3059
3060
3061 /* Match a single element of an IO list, which is either a single
3062    expression or an IO Iterator.  */
3063
3064 static match
3065 match_io_element (io_kind k, gfc_code **cpp)
3066 {
3067   gfc_expr *expr;
3068   gfc_code *cp;
3069   match m;
3070
3071   expr = NULL;
3072
3073   m = match_io_iterator (k, cpp);
3074   if (m == MATCH_YES)
3075     return MATCH_YES;
3076
3077   if (k == M_READ)
3078     {
3079       m = gfc_match_variable (&expr, 0);
3080       if (m == MATCH_NO)
3081         gfc_error ("Expected variable in READ statement at %C");
3082     }
3083   else
3084     {
3085       m = gfc_match_expr (&expr);
3086       if (m == MATCH_NO)
3087         gfc_error ("Expected expression in %s statement at %C",
3088                    io_kind_name (k));
3089     }
3090
3091   if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3092     m = MATCH_ERROR;
3093
3094   if (m != MATCH_YES)
3095     {
3096       gfc_free_expr (expr);
3097       return MATCH_ERROR;
3098     }
3099
3100   cp = gfc_get_code ();
3101   cp->op = EXEC_TRANSFER;
3102   cp->expr1 = expr;
3103   if (k != M_INQUIRE)
3104     cp->ext.dt = current_dt;
3105
3106   *cpp = cp;
3107   return MATCH_YES;
3108 }
3109
3110
3111 /* Match an I/O list, building gfc_code structures as we go.  */
3112
3113 static match
3114 match_io_list (io_kind k, gfc_code **head_p)
3115 {
3116   gfc_code *head, *tail, *new_code;
3117   match m;
3118
3119   *head_p = head = tail = NULL;
3120   if (gfc_match_eos () == MATCH_YES)
3121     return MATCH_YES;
3122
3123   for (;;)
3124     {
3125       m = match_io_element (k, &new_code);
3126       if (m == MATCH_ERROR)
3127         goto cleanup;
3128       if (m == MATCH_NO)
3129         goto syntax;
3130
3131       tail = gfc_append_code (tail, new_code);
3132       if (head == NULL)
3133         head = new_code;
3134
3135       if (gfc_match_eos () == MATCH_YES)
3136         break;
3137       if (gfc_match_char (',') != MATCH_YES)
3138         goto syntax;
3139     }
3140
3141   *head_p = head;
3142   return MATCH_YES;
3143
3144 syntax:
3145   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3146
3147 cleanup:
3148   gfc_free_statements (head);
3149   return MATCH_ERROR;
3150 }
3151
3152
3153 /* Attach the data transfer end node.  */
3154
3155 static void
3156 terminate_io (gfc_code *io_code)
3157 {
3158   gfc_code *c;
3159
3160   if (io_code == NULL)
3161     io_code = new_st.block;
3162
3163   c = gfc_get_code ();
3164   c->op = EXEC_DT_END;
3165
3166   /* Point to structure that is already there */
3167   c->ext.dt = new_st.ext.dt;
3168   gfc_append_code (io_code, c);
3169 }
3170
3171
3172 /* Check the constraints for a data transfer statement.  The majority of the
3173    constraints appearing in 9.4 of the standard appear here.  Some are handled
3174    in resolve_tag and others in gfc_resolve_dt.  */
3175
3176 static match
3177 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3178                       locus *spec_end)
3179 {
3180 #define io_constraint(condition,msg,arg)\
3181 if (condition) \
3182   {\
3183     gfc_error(msg,arg);\
3184     m = MATCH_ERROR;\
3185   }
3186
3187   match m;
3188   gfc_expr *expr;
3189   gfc_symbol *sym = NULL;
3190   bool warn, unformatted;
3191
3192   warn = (dt->err || dt->iostat) ? true : false;
3193   unformatted = dt->format_expr == NULL && dt->format_label == NULL
3194                 && dt->namelist == NULL;
3195
3196   m = MATCH_YES;
3197
3198   expr = dt->io_unit;
3199   if (expr && expr->expr_type == EXPR_VARIABLE
3200       && expr->ts.type == BT_CHARACTER)
3201     {
3202       sym = expr->symtree->n.sym;
3203
3204       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3205                      "Internal file at %L must not be INTENT(IN)",
3206                      &expr->where);
3207
3208       io_constraint (gfc_has_vector_index (dt->io_unit),
3209                      "Internal file incompatible with vector subscript at %L",
3210                      &expr->where);
3211
3212       io_constraint (dt->rec != NULL,
3213                      "REC tag at %L is incompatible with internal file",
3214                      &dt->rec->where);
3215
3216       io_constraint (dt->pos != NULL,
3217                      "POS tag at %L is incompatible with internal file",
3218                      &dt->pos->where);
3219
3220       io_constraint (unformatted,
3221                      "Unformatted I/O not allowed with internal unit at %L",
3222                      &dt->io_unit->where);
3223
3224       io_constraint (dt->asynchronous != NULL,
3225                      "ASYNCHRONOUS tag at %L not allowed with internal file",
3226                      &dt->asynchronous->where);
3227
3228       if (dt->namelist != NULL)
3229         {
3230           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
3231                               "at %L with namelist", &expr->where)
3232               == FAILURE)
3233             m = MATCH_ERROR;
3234         }
3235
3236       io_constraint (dt->advance != NULL,
3237                      "ADVANCE tag at %L is incompatible with internal file",
3238                      &dt->advance->where);
3239     }
3240
3241   if (expr && expr->ts.type != BT_CHARACTER)
3242     {
3243
3244       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3245                      "IO UNIT in %s statement at %C must be "
3246                      "an internal file in a PURE procedure",
3247                      io_kind_name (k));
3248
3249       if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
3250         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3251
3252     }
3253
3254   if (k != M_READ)
3255     {
3256       io_constraint (dt->end, "END tag not allowed with output at %L",
3257                      &dt->end_where);
3258
3259       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3260                      &dt->eor_where);
3261
3262       io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3263                      &dt->blank->where);
3264
3265       io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3266                      &dt->pad->where);
3267
3268       io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3269                      &dt->size->where);
3270     }
3271   else
3272     {
3273       io_constraint (dt->size && dt->advance == NULL,
3274                      "SIZE tag at %L requires an ADVANCE tag",
3275                      &dt->size->where);
3276
3277       io_constraint (dt->eor && dt->advance == NULL,
3278                      "EOR tag at %L requires an ADVANCE tag",
3279                      &dt->eor_where);
3280     }
3281
3282   if (dt->asynchronous)
3283     {
3284       static const char * asynchronous[] = { "YES", "NO", NULL };
3285
3286       if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3287         {
3288           gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3289                      "expression", &dt->asynchronous->where);
3290           return MATCH_ERROR;
3291         }
3292
3293       if (!compare_to_allowed_values
3294                 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3295                  dt->asynchronous->value.character.string,
3296                  io_kind_name (k), warn))
3297         return MATCH_ERROR;
3298     }
3299
3300   if (dt->id)
3301     {
3302       bool not_yes
3303         = !dt->asynchronous
3304           || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3305           || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3306                                    "yes", 3) != 0;
3307       io_constraint (not_yes,
3308                      "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3309                      "specifier", &dt->id->where);
3310     }
3311
3312   if (dt->decimal)
3313     {
3314       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3315           "not allowed in Fortran 95") == FAILURE)
3316         return MATCH_ERROR;
3317
3318       if (dt->decimal->expr_type == EXPR_CONSTANT)
3319         {
3320           static const char * decimal[] = { "COMMA", "POINT", NULL };
3321
3322           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3323                                           dt->decimal->value.character.string,
3324                                           io_kind_name (k), warn))
3325             return MATCH_ERROR;
3326
3327           io_constraint (unformatted,
3328                          "the DECIMAL= specifier at %L must be with an "
3329                          "explicit format expression", &dt->decimal->where);
3330         }
3331     }
3332
3333   if (dt->blank)
3334     {
3335       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3336           "not allowed in Fortran 95") == FAILURE)
3337         return MATCH_ERROR;
3338
3339       if (dt->blank->expr_type == EXPR_CONSTANT)
3340         {
3341           static const char * blank[] = { "NULL", "ZERO", NULL };
3342
3343           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3344                                           dt->blank->value.character.string,
3345                                           io_kind_name (k), warn))
3346             return MATCH_ERROR;
3347
3348           io_constraint (unformatted,
3349                          "the BLANK= specifier at %L must be with an "
3350                          "explicit format expression", &dt->blank->where);
3351         }
3352     }
3353
3354   if (dt->pad)
3355     {
3356       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3357           "not allowed in Fortran 95") == FAILURE)
3358         return MATCH_ERROR;
3359
3360       if (dt->pad->expr_type == EXPR_CONSTANT)
3361         {
3362           static const char * pad[] = { "YES", "NO", NULL };
3363
3364           if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3365                                           dt->pad->value.character.string,
3366                                           io_kind_name (k), warn))
3367             return MATCH_ERROR;
3368
3369           io_constraint (unformatted,
3370                          "the PAD= specifier at %L must be with an "
3371                          "explicit format expression", &dt->pad->where);
3372         }
3373     }
3374
3375   if (dt->round)
3376     {
3377       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3378           "not allowed in Fortran 95") == FAILURE)
3379         return MATCH_ERROR;
3380
3381       if (dt->round->expr_type == EXPR_CONSTANT)
3382         {
3383           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3384                                           "COMPATIBLE", "PROCESSOR_DEFINED",
3385                                           NULL };
3386
3387           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3388                                           dt->round->value.character.string,
3389                                           io_kind_name (k), warn))
3390             return MATCH_ERROR;
3391         }
3392     }
3393
3394   if (dt->sign)
3395     {
3396       /* When implemented, change the following to use gfc_notify_std F2003.
3397       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3398           "not allowed in Fortran 95") == FAILURE)
3399         return MATCH_ERROR;  */
3400       if (dt->sign->expr_type == EXPR_CONSTANT)
3401         {
3402           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3403                                          NULL };
3404
3405           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3406                                       dt->sign->value.character.string,
3407                                       io_kind_name (k), warn))
3408             return MATCH_ERROR;
3409
3410           io_constraint (unformatted,
3411                          "SIGN= specifier at %L must be with an "
3412                          "explicit format expression", &dt->sign->where);
3413
3414           io_constraint (k == M_READ,
3415                          "SIGN= specifier at %L not allowed in a "
3416                          "READ statement", &dt->sign->where);
3417         }
3418     }
3419
3420   if (dt->delim)
3421     {
3422       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3423           "not allowed in Fortran 95") == FAILURE)
3424         return MATCH_ERROR;
3425
3426       if (dt->delim->expr_type == EXPR_CONSTANT)
3427         {
3428           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3429
3430           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3431                                           dt->delim->value.character.string,
3432                                           io_kind_name (k), warn))
3433             return MATCH_ERROR;
3434
3435           io_constraint (k == M_READ,
3436                          "DELIM= specifier at %L not allowed in a "
3437                          "READ statement", &dt->delim->where);
3438
3439           io_constraint (dt->format_label != &format_asterisk
3440                          && dt->namelist == NULL,
3441                          "DELIM= specifier at %L must have FMT=*",
3442                          &dt->delim->where);
3443
3444           io_constraint (unformatted && dt->namelist == NULL,
3445                          "DELIM= specifier at %L must be with FMT=* or "
3446                          "NML= specifier ", &dt->delim->where);
3447         }
3448     }
3449
3450   if (dt->namelist)
3451     {
3452       io_constraint (io_code && dt->namelist,
3453                      "NAMELIST cannot be followed by IO-list at %L",
3454                      &io_code->loc);
3455
3456       io_constraint (dt->format_expr,
3457                      "IO spec-list cannot contain both NAMELIST group name "
3458                      "and format specification at %L",
3459                      &dt->format_expr->where);
3460
3461       io_constraint (dt->format_label,
3462                      "IO spec-list cannot contain both NAMELIST group name "
3463                      "and format label at %L", spec_end);
3464
3465       io_constraint (dt->rec,
3466                      "NAMELIST IO is not allowed with a REC= specifier "
3467                      "at %L", &dt->rec->where);
3468
3469       io_constraint (dt->advance,
3470                      "NAMELIST IO is not allowed with a ADVANCE= specifier "
3471                      "at %L", &dt->advance->where);
3472     }
3473
3474   if (dt->rec)
3475     {
3476       io_constraint (dt->end,
3477                      "An END tag is not allowed with a "
3478                      "REC= specifier at %L", &dt->end_where);
3479
3480       io_constraint (dt->format_label == &format_asterisk,
3481                      "FMT=* is not allowed with a REC= specifier "
3482                      "at %L", spec_end);
3483
3484       io_constraint (dt->pos,
3485                      "POS= is not allowed with REC= specifier "
3486                      "at %L", &dt->pos->where);
3487     }
3488
3489   if (dt->advance)
3490     {
3491       int not_yes, not_no;
3492       expr = dt->advance;
3493
3494       io_constraint (dt->format_label == &format_asterisk,
3495                      "List directed format(*) is not allowed with a "
3496                      "ADVANCE= specifier at %L.", &expr->where);
3497
3498       io_constraint (unformatted,
3499                      "the ADVANCE= specifier at %L must appear with an "
3500                      "explicit format expression", &expr->where);
3501
3502       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3503         {
3504           const gfc_char_t *advance = expr->value.character.string;
3505           not_no = gfc_wide_strlen (advance) != 2
3506                    || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3507           not_yes = gfc_wide_strlen (advance) != 3
3508                     || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3509         }
3510       else
3511         {
3512           not_no = 0;
3513           not_yes = 0;
3514         }
3515
3516       io_constraint (not_no && not_yes,
3517                      "ADVANCE= specifier at %L must have value = "
3518                      "YES or NO.", &expr->where);
3519
3520       io_constraint (dt->size && not_no && k == M_READ,
3521                      "SIZE tag at %L requires an ADVANCE = 'NO'",
3522                      &dt->size->where);
3523
3524       io_constraint (dt->eor && not_no && k == M_READ,
3525                      "EOR tag at %L requires an ADVANCE = 'NO'",
3526                      &dt->eor_where);
3527     }
3528
3529   expr = dt->format_expr;
3530   if (gfc_simplify_expr (expr, 0) == FAILURE
3531       || check_format_string (expr, k == M_READ) == FAILURE)
3532     return MATCH_ERROR;
3533
3534   return m;
3535 }
3536 #undef io_constraint
3537
3538
3539 /* Match a READ, WRITE or PRINT statement.  */
3540
3541 static match
3542 match_io (io_kind k)
3543 {
3544   char name[GFC_MAX_SYMBOL_LEN + 1];
3545   gfc_code *io_code;
3546   gfc_symbol *sym;
3547   int comma_flag;
3548   locus where;
3549   locus spec_end;
3550   gfc_dt *dt;
3551   match m;
3552
3553   where = gfc_current_locus;
3554   comma_flag = 0;
3555   current_dt = dt = XCNEW (gfc_dt);
3556   m = gfc_match_char ('(');
3557   if (m == MATCH_NO)
3558     {
3559       where = gfc_current_locus;
3560       if (k == M_WRITE)
3561         goto syntax;
3562       else if (k == M_PRINT)
3563         {
3564           /* Treat the non-standard case of PRINT namelist.  */
3565           if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3566               && gfc_match_name (name) == MATCH_YES)
3567             {
3568               gfc_find_symbol (name, NULL, 1, &sym);
3569               if (sym && sym->attr.flavor == FL_NAMELIST)
3570                 {
3571                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3572                                       "%C is an extension") == FAILURE)
3573                     {
3574                       m = MATCH_ERROR;
3575                       goto cleanup;
3576                     }
3577
3578                   dt->io_unit = default_unit (k);
3579                   dt->namelist = sym;
3580                   goto get_io_list;
3581                 }
3582               else
3583                 gfc_current_locus = where;
3584             }
3585         }
3586
3587       if (gfc_current_form == FORM_FREE)
3588         {
3589           char c = gfc_peek_ascii_char ();
3590           if (c != ' ' && c != '*' && c != '\'' && c != '"')
3591             {
3592               m = MATCH_NO;
3593               goto cleanup;
3594             }
3595         }
3596
3597       m = match_dt_format (dt);
3598       if (m == MATCH_ERROR)
3599         goto cleanup;
3600       if (m == MATCH_NO)
3601         goto syntax;
3602
3603       comma_flag = 1;
3604       dt->io_unit = default_unit (k);
3605       goto get_io_list;
3606     }
3607   else
3608     {
3609       /* Before issuing an error for a malformed 'print (1,*)' type of
3610          error, check for a default-char-expr of the form ('(I0)').  */
3611       if (k == M_PRINT && m == MATCH_YES)
3612         {
3613           /* Reset current locus to get the initial '(' in an expression.  */
3614           gfc_current_locus = where;
3615           dt->format_expr = NULL;
3616           m = match_dt_format (dt);
3617
3618           if (m == MATCH_ERROR)
3619             goto cleanup;
3620           if (m == MATCH_NO || dt->format_expr == NULL)
3621             goto syntax;
3622
3623           comma_flag = 1;
3624           dt->io_unit = default_unit (k);
3625           goto get_io_list;
3626         }
3627     }
3628
3629   /* Match a control list */
3630   if (match_dt_element (k, dt) == MATCH_YES)
3631     goto next;
3632   if (match_dt_unit (k, dt) != MATCH_YES)
3633     goto loop;
3634
3635   if (gfc_match_char (')') == MATCH_YES)
3636     goto get_io_list;
3637   if (gfc_match_char (',') != MATCH_YES)
3638     goto syntax;
3639
3640   m = match_dt_element (k, dt);
3641   if (m == MATCH_YES)
3642     goto next;
3643   if (m == MATCH_ERROR)
3644     goto cleanup;
3645
3646   m = match_dt_format (dt);
3647   if (m == MATCH_YES)
3648     goto next;
3649   if (m == MATCH_ERROR)
3650     goto cleanup;
3651
3652   where = gfc_current_locus;
3653
3654   m = gfc_match_name (name);
3655   if (m == MATCH_YES)
3656     {
3657       gfc_find_symbol (name, NULL, 1, &sym);
3658       if (sym && sym->attr.flavor == FL_NAMELIST)
3659         {
3660           dt->namelist = sym;
3661           if (k == M_READ && check_namelist (sym))
3662             {
3663               m = MATCH_ERROR;
3664               goto cleanup;
3665             }
3666           goto next;
3667         }
3668     }
3669
3670   gfc_current_locus = where;
3671
3672   goto loop;                    /* No matches, try regular elements */
3673
3674 next:
3675   if (gfc_match_char (')') == MATCH_YES)
3676     goto get_io_list;
3677   if (gfc_match_char (',') != MATCH_YES)
3678     goto syntax;
3679
3680 loop:
3681   for (;;)
3682     {
3683       m = match_dt_element (k, dt);
3684       if (m == MATCH_NO)
3685         goto syntax;
3686       if (m == MATCH_ERROR)
3687         goto cleanup;
3688
3689       if (gfc_match_char (')') == MATCH_YES)
3690         break;
3691       if (gfc_match_char (',') != MATCH_YES)
3692         goto syntax;
3693     }
3694
3695 get_io_list:
3696
3697   /* Used in check_io_constraints, where no locus is available.  */
3698   spec_end = gfc_current_locus;
3699
3700   /* Save the IO kind for later use.  */
3701   dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
3702
3703   /* Optional leading comma (non-standard).  We use a gfc_expr structure here
3704      to save the locus.  This is used later when resolving transfer statements
3705      that might have a format expression without unit number.  */
3706   if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3707     dt->extra_comma = dt->dt_io_kind;
3708
3709   io_code = NULL;
3710   if (gfc_match_eos () != MATCH_YES)
3711     {
3712       if (comma_flag && gfc_match_char (',') != MATCH_YES)
3713         {
3714           gfc_error ("Expected comma in I/O list at %C");
3715           m = MATCH_ERROR;
3716           goto cleanup;
3717         }
3718
3719       m = match_io_list (k, &io_code);
3720       if (m == MATCH_ERROR)
3721         goto cleanup;
3722       if (m == MATCH_NO)
3723         goto syntax;
3724     }
3725
3726   /* A full IO statement has been matched.  Check the constraints.  spec_end is
3727      supplied for cases where no locus is supplied.  */
3728   m = check_io_constraints (k, dt, io_code, &spec_end);
3729
3730   if (m == MATCH_ERROR)
3731     goto cleanup;
3732
3733   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3734   new_st.ext.dt = dt;
3735   new_st.block = gfc_get_code ();
3736   new_st.block->op = new_st.op;
3737   new_st.block->next = io_code;
3738
3739   terminate_io (io_code);
3740
3741   return MATCH_YES;
3742
3743 syntax:
3744   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3745   m = MATCH_ERROR;
3746
3747 cleanup:
3748   gfc_free_dt (dt);
3749   return m;
3750 }
3751
3752
3753 match
3754 gfc_match_read (void)
3755 {
3756   return match_io (M_READ);
3757 }
3758
3759
3760 match
3761 gfc_match_write (void)
3762 {
3763   return match_io (M_WRITE);
3764 }
3765
3766
3767 match
3768 gfc_match_print (void)
3769 {
3770   match m;
3771
3772   m = match_io (M_PRINT);
3773   if (m != MATCH_YES)
3774     return m;
3775
3776   if (gfc_pure (NULL))
3777     {
3778       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3779       return MATCH_ERROR;
3780     }
3781
3782   if (gfc_implicit_pure (NULL))
3783     gfc_current_ns->proc_name->attr.implicit_pure = 0;
3784
3785   return MATCH_YES;
3786 }
3787
3788
3789 /* Free a gfc_inquire structure.  */
3790
3791 void
3792 gfc_free_inquire (gfc_inquire *inquire)
3793 {
3794
3795   if (inquire == NULL)
3796     return;
3797
3798   gfc_free_expr (inquire->unit);
3799   gfc_free_expr (inquire->file);
3800   gfc_free_expr (inquire->iomsg);
3801   gfc_free_expr (inquire->iostat);
3802   gfc_free_expr (inquire->exist);
3803   gfc_free_expr (inquire->opened);
3804   gfc_free_expr (inquire->number);
3805   gfc_free_expr (inquire->named);
3806   gfc_free_expr (inquire->name);
3807   gfc_free_expr (inquire->access);
3808   gfc_free_expr (inquire->sequential);
3809   gfc_free_expr (inquire->direct);
3810   gfc_free_expr (inquire->form);
3811   gfc_free_expr (inquire->formatted);
3812   gfc_free_expr (inquire->unformatted);
3813   gfc_free_expr (inquire->recl);
3814   gfc_free_expr (inquire->nextrec);
3815   gfc_free_expr (inquire->blank);
3816   gfc_free_expr (inquire->position);
3817   gfc_free_expr (inquire->action);
3818   gfc_free_expr (inquire->read);
3819   gfc_free_expr (inquire->write);
3820   gfc_free_expr (inquire->readwrite);
3821   gfc_free_expr (inquire->delim);
3822   gfc_free_expr (inquire->encoding);
3823   gfc_free_expr (inquire->pad);
3824   gfc_free_expr (inquire->iolength);
3825   gfc_free_expr (inquire->convert);
3826   gfc_free_expr (inquire->strm_pos);
3827   gfc_free_expr (inquire->asynchronous);
3828   gfc_free_expr (inquire->decimal);
3829   gfc_free_expr (inquire->pending);
3830   gfc_free_expr (inquire->id);
3831   gfc_free_expr (inquire->sign);
3832   gfc_free_expr (inquire->size);
3833   gfc_free_expr (inquire->round);
3834   free (inquire);
3835 }
3836
3837
3838 /* Match an element of an INQUIRE statement.  */
3839
3840 #define RETM   if (m != MATCH_NO) return m;
3841
3842 static match
3843 match_inquire_element (gfc_inquire *inquire)
3844 {
3845   match m;
3846
3847   m = match_etag (&tag_unit, &inquire->unit);
3848   RETM m = match_etag (&tag_file, &inquire->file);
3849   RETM m = match_ltag (&tag_err, &inquire->err);
3850   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3851   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3852   RETM m = match_vtag (&tag_exist, &inquire->exist);
3853   RETM m = match_vtag (&tag_opened, &inquire->opened);
3854   RETM m = match_vtag (&tag_named, &inquire->named);
3855   RETM m = match_vtag (&tag_name, &inquire->name);
3856   RETM m = match_out_tag (&tag_number, &inquire->number);
3857   RETM m = match_vtag (&tag_s_access, &inquire->access);
3858   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3859   RETM m = match_vtag (&tag_direct, &inquire->direct);
3860   RETM m = match_vtag (&tag_s_form, &inquire->form);
3861   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3862   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3863   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3864   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3865   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3866   RETM m = match_vtag (&tag_s_position, &inquire->position);
3867   RETM m = match_vtag (&tag_s_action, &inquire->action);
3868   RETM m = match_vtag (&tag_read, &inquire->read);
3869   RETM m = match_vtag (&tag_write, &inquire->write);
3870   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3871   RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3872   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3873   RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3874   RETM m = match_vtag (&tag_size, &inquire->size);
3875   RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3876   RETM m = match_vtag (&tag_s_round, &inquire->round);
3877   RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3878   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3879   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3880   RETM m = match_vtag (&tag_convert, &inquire->convert);
3881   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3882   RETM m = match_vtag (&tag_pending, &inquire->pending);
3883   RETM m = match_vtag (&tag_id, &inquire->id);
3884   RETM return MATCH_NO;
3885 }
3886
3887 #undef RETM
3888
3889
3890 match
3891 gfc_match_inquire (void)
3892 {
3893   gfc_inquire *inquire;
3894   gfc_code *code;
3895   match m;
3896   locus loc;
3897
3898   m = gfc_match_char ('(');
3899   if (m == MATCH_NO)
3900     return m;
3901
3902   inquire = XCNEW (gfc_inquire);
3903
3904   loc = gfc_current_locus;
3905
3906   m = match_inquire_element (inquire);
3907   if (m == MATCH_ERROR)
3908     goto cleanup;
3909   if (m == MATCH_NO)
3910     {
3911       m = gfc_match_expr (&inquire->unit);
3912       if (m == MATCH_ERROR)
3913         goto cleanup;
3914       if (m == MATCH_NO)
3915         goto syntax;
3916     }
3917
3918   /* See if we have the IOLENGTH form of the inquire statement.  */
3919   if (inquire->iolength != NULL)
3920     {
3921       if (gfc_match_char (')') != MATCH_YES)
3922         goto syntax;
3923
3924       m = match_io_list (M_INQUIRE, &code);
3925       if (m == MATCH_ERROR)
3926         goto cleanup;
3927       if (m == MATCH_NO)
3928         goto syntax;
3929
3930       new_st.op = EXEC_IOLENGTH;
3931       new_st.expr1 = inquire->iolength;
3932       new_st.ext.inquire = inquire;
3933
3934       if (gfc_pure (NULL))
3935         {
3936           gfc_free_statements (code);
3937           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3938           return MATCH_ERROR;
3939         }
3940
3941       if (gfc_implicit_pure (NULL))
3942         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3943
3944       new_st.block = gfc_get_code ();
3945       new_st.block->op = EXEC_IOLENGTH;
3946       terminate_io (code);
3947       new_st.block->next = code;
3948       return MATCH_YES;
3949     }
3950
3951   /* At this point, we have the non-IOLENGTH inquire statement.  */
3952   for (;;)
3953     {
3954       if (gfc_match_char (')') == MATCH_YES)
3955         break;
3956       if (gfc_match_char (',') != MATCH_YES)
3957         goto syntax;
3958
3959       m = match_inquire_element (inquire);
3960       if (m == MATCH_ERROR)
3961         goto cleanup;
3962       if (m == MATCH_NO)
3963         goto syntax;
3964
3965       if (inquire->iolength != NULL)
3966         {
3967           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3968           goto cleanup;
3969         }
3970     }
3971
3972   if (gfc_match_eos () != MATCH_YES)
3973     goto syntax;
3974
3975   if (inquire->unit != NULL && inquire->file != NULL)
3976     {
3977       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3978                  "UNIT specifiers", &loc);
3979       goto cleanup;
3980     }
3981
3982   if (inquire->unit == NULL && inquire->file == NULL)
3983     {
3984       gfc_error ("INQUIRE statement at %L requires either FILE or "
3985                  "UNIT specifier", &loc);
3986       goto cleanup;
3987     }
3988
3989   if (gfc_pure (NULL))
3990     {
3991       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3992       goto cleanup;
3993     }
3994
3995   if (gfc_implicit_pure (NULL))
3996     gfc_current_ns->proc_name->attr.implicit_pure = 0;
3997
3998   if (inquire->id != NULL && inquire->pending == NULL)
3999     {
4000       gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4001                  "the ID= specifier", &loc);
4002       goto cleanup;
4003     }
4004
4005   new_st.op = EXEC_INQUIRE;
4006   new_st.ext.inquire = inquire;
4007   return MATCH_YES;
4008
4009 syntax:
4010   gfc_syntax_error (ST_INQUIRE);
4011
4012 cleanup:
4013   gfc_free_inquire (inquire);
4014   return MATCH_ERROR;
4015 }
4016
4017
4018 /* Resolve everything in a gfc_inquire structure.  */
4019
4020 gfc_try
4021 gfc_resolve_inquire (gfc_inquire *inquire)
4022 {
4023   RESOLVE_TAG (&tag_unit, inquire->unit);
4024   RESOLVE_TAG (&tag_file, inquire->file);
4025   RESOLVE_TAG (&tag_id, inquire->id);
4026
4027   /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4028      contexts.  Thus, use an extended RESOLVE_TAG macro for that.  */
4029 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4030   RESOLVE_TAG (tag, expr); \
4031   if (expr) \
4032     { \
4033       char context[64]; \
4034       sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4035       if (gfc_check_vardef_context ((expr), false, false, context) == FAILURE) \
4036         return FAILURE; \
4037     }
4038   INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4039   INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4040   INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4041   INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4042   INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4043   INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4044   INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4045   INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4046   INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4047   INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4048   INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4049   INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4050   INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4051   INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4052   INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4053   INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4054   INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4055   INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4056   INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4057   INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4058   INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4059   INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4060   INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4061   INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4062   INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4063   INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4064   INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4065   INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4066   INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4067   INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4068   INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4069   INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4070   INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4071   INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4072 #undef INQUIRE_RESOLVE_TAG
4073
4074   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
4075     return FAILURE;
4076
4077   return SUCCESS;
4078 }
4079
4080
4081 void
4082 gfc_free_wait (gfc_wait *wait)
4083 {
4084   if (wait == NULL)
4085     return;
4086
4087   gfc_free_expr (wait->unit);
4088   gfc_free_expr (wait->iostat);
4089   gfc_free_expr (wait->iomsg);
4090   gfc_free_expr (wait->id);
4091 }
4092
4093
4094 gfc_try
4095 gfc_resolve_wait (gfc_wait *wait)
4096 {
4097   RESOLVE_TAG (&tag_unit, wait->unit);
4098   RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4099   RESOLVE_TAG (&tag_iostat, wait->iostat);
4100   RESOLVE_TAG (&tag_id, wait->id);
4101
4102   if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
4103     return FAILURE;
4104
4105   if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
4106     return FAILURE;
4107
4108   return SUCCESS;
4109 }
4110
4111 /* Match an element of a WAIT statement.  */
4112
4113 #define RETM   if (m != MATCH_NO) return m;
4114
4115 static match
4116 match_wait_element (gfc_wait *wait)
4117 {
4118   match m;
4119
4120   m = match_etag (&tag_unit, &wait->unit);
4121   RETM m = match_ltag (&tag_err, &wait->err);
4122   RETM m = match_ltag (&tag_end, &wait->eor);
4123   RETM m = match_ltag (&tag_eor, &wait->end);
4124   RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4125   RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4126   RETM m = match_etag (&tag_id, &wait->id);
4127   RETM return MATCH_NO;
4128 }
4129
4130 #undef RETM
4131
4132
4133 match
4134 gfc_match_wait (void)
4135 {
4136   gfc_wait *wait;
4137   match m;
4138
4139   m = gfc_match_char ('(');
4140   if (m == MATCH_NO)
4141     return m;
4142
4143   wait = XCNEW (gfc_wait);
4144
4145   m = match_wait_element (wait);
4146   if (m == MATCH_ERROR)
4147     goto cleanup;
4148   if (m == MATCH_NO)
4149     {
4150       m = gfc_match_expr (&wait->unit);
4151       if (m == MATCH_ERROR)
4152         goto cleanup;
4153       if (m == MATCH_NO)
4154         goto syntax;
4155     }
4156
4157   for (;;)
4158     {
4159       if (gfc_match_char (')') == MATCH_YES)
4160         break;
4161       if (gfc_match_char (',') != MATCH_YES)
4162         goto syntax;
4163
4164       m = match_wait_element (wait);
4165       if (m == MATCH_ERROR)
4166         goto cleanup;
4167       if (m == MATCH_NO)
4168         goto syntax;
4169     }
4170
4171   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
4172           "not allowed in Fortran 95") == FAILURE)
4173     goto cleanup;
4174
4175   if (gfc_pure (NULL))
4176     {
4177       gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4178       goto cleanup;
4179     }
4180
4181   if (gfc_implicit_pure (NULL))
4182     gfc_current_ns->proc_name->attr.implicit_pure = 0;
4183
4184   new_st.op = EXEC_WAIT;
4185   new_st.ext.wait = wait;
4186
4187   return MATCH_YES;
4188
4189 syntax:
4190   gfc_syntax_error (ST_WAIT);
4191
4192 cleanup:
4193   gfc_free_wait (wait);
4194   return MATCH_ERROR;
4195 }