gcc/fortran/io.c

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