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