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