gcc/fortran/io.c

   1 /* Deal with I/O statements & related stuff.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   3    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 format_asterisk =
  31   { -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 0,
  32     {NULL, NULL}, 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_format      = {"FORMAT", NULL, BT_CHARACTER},
  56         tag_iostat      = {"IOSTAT", " iostat = %v", BT_INTEGER},
  57         tag_size        = {"SIZE", " size = %v", BT_INTEGER},
  58         tag_exist       = {"EXIST", " exist = %v", BT_LOGICAL},
  59         tag_opened      = {"OPENED", " opened = %v", BT_LOGICAL},
  60         tag_named       = {"NAMED", " named = %v", BT_LOGICAL},
  61         tag_name        = {"NAME", " name = %v", BT_CHARACTER},
  62         tag_number      = {"NUMBER", " number = %v", BT_INTEGER},
  63         tag_s_access    = {"ACCESS", " access = %v", BT_CHARACTER},
  64         tag_sequential  = {"SEQUENTIAL", " sequential = %v", BT_CHARACTER},
  65         tag_direct      = {"DIRECT", " direct = %v", BT_CHARACTER},
  66         tag_s_form      = {"FORM", " form = %v", BT_CHARACTER},
  67         tag_formatted   = {"FORMATTED", " formatted = %v", BT_CHARACTER},
  68         tag_unformatted = {"UNFORMATTED", " unformatted = %v", BT_CHARACTER},
  69         tag_s_recl      = {"RECL", " recl = %v", BT_INTEGER},
  70         tag_nextrec     = {"NEXTREC", " nextrec = %v", BT_INTEGER},
  71         tag_s_blank     = {"BLANK", " blank = %v", BT_CHARACTER},
  72         tag_s_position  = {"POSITION", " position = %v", BT_CHARACTER},
  73         tag_s_action    = {"ACTION", " action = %v", BT_CHARACTER},
  74         tag_read        = {"READ", " read = %v", BT_CHARACTER},
  75         tag_write       = {"WRITE", " write = %v", BT_CHARACTER},
  76         tag_readwrite   = {"READWRITE", " readwrite = %v", BT_CHARACTER},
  77         tag_s_delim     = {"DELIM", " delim = %v", BT_CHARACTER},
  78         tag_s_pad       = {"PAD", " pad = %v", BT_CHARACTER},
  79         tag_iolength    = {"IOLENGTH", " iolength = %v", BT_INTEGER},
  80         tag_err         = {"ERR", " err = %l", BT_UNKNOWN},
  81         tag_end         = {"END", " end = %l", BT_UNKNOWN},
  82         tag_eor         = {"EOR", " eor = %l", BT_UNKNOWN};
  83
  84 static gfc_dt *current_dt;
  85
  86 #define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;
  87
  88
  89 /**************** Fortran 95 FORMAT parser  *****************/
  90
  91 /* FORMAT tokens returned by format_lex().  */
  92 typedef enum
  93 {
  94   FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
  95   FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_POS, FMT_LPAREN,
  96   FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
  97   FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END
  98 }
  99 format_token;
 100
 101 /* Local variables for checking format strings.  The saved_token is
 102    used to back up by a single format token during the parsing
 103    process.  */
 104 static char *format_string;
 105 static int format_length, use_last_char;
 106
 107 static format_token saved_token;
 108
 109 static enum
 110 { MODE_STRING, MODE_FORMAT, MODE_COPY }
 111 mode;
 112
 113
 114 /* Return the next character in the format string.  */
 115
 116 static char
 117 next_char (int in_string)
 118 {
 119   static char c;
 120
 121   if (use_last_char)
 122     {
 123       use_last_char = 0;
 124       return c;
 125     }
 126
 127   format_length++;
 128
 129   if (mode == MODE_STRING)
 130     c = *format_string++;
 131   else
 132     {
 133       c = gfc_next_char_literal (in_string);
 134       if (c == '\n')
 135         c = '\0';
 136
 137       if (mode == MODE_COPY)
 138         *format_string++ = c;
 139     }
 140
 141   c = TOUPPER (c);
 142   return c;
 143 }
 144
 145
 146 /* Back up one character position.  Only works once.  */
 147
 148 static void
 149 unget_char (void)
 150 {
 151
 152   use_last_char = 1;
 153 }
 154
 155 static int value = 0;
 156
 157 /* Simple lexical analyzer for getting the next token in a FORMAT
 158    statement.  */
 159
 160 static format_token
 161 format_lex (void)
 162 {
 163   format_token token;
 164   char c, delim;
 165   int zflag;
 166   int negative_flag;
 167
 168   if (saved_token != FMT_NONE)
 169     {
 170       token = saved_token;
 171       saved_token = FMT_NONE;
 172       return token;
 173     }
 174
 175   do
 176     {
 177       c = next_char (0);
 178     }
 179   while (gfc_is_whitespace (c));
 180
 181   negative_flag = 0;
 182   switch (c)
 183     {
 184     case '-':
 185       negative_flag = 1;
 186     case '+':
 187       c = next_char (0);
 188       if (!ISDIGIT (c))
 189         {
 190           token = FMT_UNKNOWN;
 191           break;
 192         }
 193
 194       value = c - '0';
 195
 196       do
 197         {
 198           c = next_char (0);
 199           if(ISDIGIT (c))
 200             value = 10 * value + c - '0';
 201         }
 202       while (ISDIGIT (c));
 203
 204       unget_char ();
 205
 206       if (negative_flag)
 207         value = -value;
 208
 209       token = FMT_SIGNED_INT;
 210       break;
 211
 212     case '0':
 213     case '1':
 214     case '2':
 215     case '3':
 216     case '4':
 217     case '5':
 218     case '6':
 219     case '7':
 220     case '8':
 221     case '9':
 222       zflag = (c == '0');
 223
 224       value = c - '0';
 225
 226       do
 227         {
 228           c = next_char (0);
 229           if (c != '0')
 230             zflag = 0;
 231           if (ISDIGIT (c))
 232             value = 10 * value + c - '0';
 233         }
 234       while (ISDIGIT (c));
 235
 236       unget_char ();
 237       token = zflag ? FMT_ZERO : FMT_POSINT;
 238       break;
 239
 240     case '.':
 241       token = FMT_PERIOD;
 242       break;
 243
 244     case ',':
 245       token = FMT_COMMA;
 246       break;
 247
 248     case ':':
 249       token = FMT_COLON;
 250       break;
 251
 252     case '/':
 253       token = FMT_SLASH;
 254       break;
 255
 256     case '$':
 257       token = FMT_DOLLAR;
 258       break;
 259
 260     case 'T':
 261       c = next_char (0);
 262       if (c != 'L' && c != 'R')
 263         unget_char ();
 264
 265       token = FMT_POS;
 266       break;
 267
 268     case '(':
 269       token = FMT_LPAREN;
 270       break;
 271
 272     case ')':
 273       token = FMT_RPAREN;
 274       break;
 275
 276     case 'X':
 277       token = FMT_X;
 278       break;
 279
 280     case 'S':
 281       c = next_char (0);
 282       if (c != 'P' && c != 'S')
 283         unget_char ();
 284
 285       token = FMT_SIGN;
 286       break;
 287
 288     case 'B':
 289       c = next_char (0);
 290       if (c == 'N' || c == 'Z')
 291         token = FMT_BLANK;
 292       else
 293         {
 294           unget_char ();
 295           token = FMT_IBOZ;
 296         }
 297
 298       break;
 299
 300     case '\'':
 301     case '"':
 302       delim = c;
 303
 304       value = 0;
 305
 306       for (;;)
 307         {
 308           c = next_char (1);
 309           if (c == '\0')
 310             {
 311               token = FMT_END;
 312               break;
 313             }
 314
 315           if (c == delim)
 316             {
 317               c = next_char (1);
 318
 319               if (c == '\0')
 320                 {
 321                   token = FMT_END;
 322                   break;
 323                 }
 324
 325               if (c != delim)
 326                 {
 327                   unget_char ();
 328                   token = FMT_CHAR;
 329                   break;
 330                 }
 331             }
 332           value++;
 333         }
 334       break;
 335
 336     case 'P':
 337       token = FMT_P;
 338       break;
 339
 340     case 'I':
 341     case 'O':
 342     case 'Z':
 343       token = FMT_IBOZ;
 344       break;
 345
 346     case 'F':
 347       token = FMT_F;
 348       break;
 349
 350     case 'E':
 351       c = next_char (0);
 352       if (c == 'N' || c == 'S')
 353         token = FMT_EXT;
 354       else
 355         {
 356           token = FMT_E;
 357           unget_char ();
 358         }
 359
 360       break;
 361
 362     case 'G':
 363       token = FMT_G;
 364       break;
 365
 366     case 'H':
 367       token = FMT_H;
 368       break;
 369
 370     case 'L':
 371       token = FMT_L;
 372       break;
 373
 374     case 'A':
 375       token = FMT_A;
 376       break;
 377
 378     case 'D':
 379       token = FMT_D;
 380       break;
 381
 382     case '\0':
 383       token = FMT_END;
 384       break;
 385
 386     default:
 387       token = FMT_UNKNOWN;
 388       break;
 389     }
 390
 391   return token;
 392 }
 393
 394
 395 /* Check a format statement.  The format string, either from a FORMAT
 396    statement or a constant in an I/O statement has already been parsed
 397    by itself, and we are checking it for validity.  The dual origin
 398    means that the warning message is a little less than great.  */
 399
 400 static try
 401 check_format (void)
 402 {
 403   const char *posint_required     = "Positive width required";
 404   const char *period_required     = "Period required";
 405   const char *nonneg_required     = "Nonnegative width required";
 406   const char *unexpected_element  = "Unexpected element";
 407   const char *unexpected_end      = "Unexpected end of format string";
 408
 409   const char *error;
 410   format_token t, u;
 411   int level;
 412   int repeat;
 413   try rv;
 414
 415   use_last_char = 0;
 416   saved_token = FMT_NONE;
 417   level = 0;
 418   repeat = 0;
 419   rv = SUCCESS;
 420
 421   t = format_lex ();
 422   if (t != FMT_LPAREN)
 423     {
 424       error = "Missing leading left parenthesis";
 425       goto syntax;
 426     }
 427
 428   t = format_lex ();
 429   if (t == FMT_RPAREN)
 430     goto finished;              /* Empty format is legal */
 431   saved_token = t;
 432
 433 format_item:
 434   /* In this state, the next thing has to be a format item.  */
 435   t = format_lex ();
 436 format_item_1:
 437   switch (t)
 438     {
 439     case FMT_POSINT:
 440       repeat = value;
 441       t = format_lex ();
 442       if (t == FMT_LPAREN)
 443         {
 444           level++;
 445           goto format_item;
 446         }
 447
 448       if (t == FMT_SLASH)
 449         goto optional_comma;
 450
 451       goto data_desc;
 452
 453     case FMT_LPAREN:
 454       level++;
 455       goto format_item;
 456
 457     case FMT_SIGNED_INT:
 458       /* Signed integer can only precede a P format.  */
 459       t = format_lex ();
 460       if (t != FMT_P)
 461         {
 462           error = "Expected P edit descriptor";
 463           goto syntax;
 464         }
 465
 466       goto data_desc;
 467
 468     case FMT_P:
 469       /* P requires a prior number.  */
 470       error = "P descriptor requires leading scale factor";
 471       goto syntax;
 472
 473     case FMT_X:
 474       /* X requires a prior number if we're being pedantic.  */
 475       if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
 476                           "requires leading space count at %C")
 477           == FAILURE)
 478         return FAILURE;
 479       goto between_desc;
 480
 481     case FMT_SIGN:
 482     case FMT_BLANK:
 483       goto between_desc;
 484
 485     case FMT_CHAR:
 486       goto extension_optional_comma;
 487
 488     case FMT_COLON:
 489     case FMT_SLASH:
 490       goto optional_comma;
 491
 492     case FMT_DOLLAR:
 493       t = format_lex ();
 494
 495       if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
 496           == FAILURE)
 497         return FAILURE;
 498       if (t != FMT_RPAREN || level > 0)
 499         {
 500           error = "$ must be the last specifier";
 501           goto syntax;
 502         }
 503
 504       goto finished;
 505
 506     case FMT_POS:
 507     case FMT_IBOZ:
 508     case FMT_F:
 509     case FMT_E:
 510     case FMT_EXT:
 511     case FMT_G:
 512     case FMT_L:
 513     case FMT_A:
 514     case FMT_D:
 515       goto data_desc;
 516
 517     case FMT_H:
 518       goto data_desc;
 519
 520     case FMT_END:
 521       error = unexpected_end;
 522       goto syntax;
 523
 524     default:
 525       error = unexpected_element;
 526       goto syntax;
 527     }
 528
 529 data_desc:
 530   /* In this state, t must currently be a data descriptor.
 531      Deal with things that can/must follow the descriptor.  */
 532   switch (t)
 533     {
 534     case FMT_SIGN:
 535     case FMT_BLANK:
 536     case FMT_X:
 537       break;
 538
 539     case FMT_P:
 540       if (pedantic)
 541         {
 542           t = format_lex ();
 543           if (t == FMT_POSINT)
 544             {
 545               error = "Repeat count cannot follow P descriptor";
 546               goto syntax;
 547             }
 548
 549           saved_token = t;
 550         }
 551
 552       goto optional_comma;
 553
 554     case FMT_POS:
 555     case FMT_L:
 556       t = format_lex ();
 557       if (t == FMT_POSINT)
 558         break;
 559
 560       error = posint_required;
 561       goto syntax;
 562
 563     case FMT_A:
 564       t = format_lex ();
 565       if (t != FMT_POSINT)
 566         saved_token = t;
 567       break;
 568
 569     case FMT_D:
 570     case FMT_E:
 571     case FMT_G:
 572     case FMT_EXT:
 573       u = format_lex ();
 574       if (u != FMT_POSINT)
 575         {
 576           error = posint_required;
 577           goto syntax;
 578         }
 579
 580       u = format_lex ();
 581       if (u != FMT_PERIOD)
 582         {
 583           error = period_required;
 584           goto syntax;
 585         }
 586
 587       u = format_lex ();
 588       if (u != FMT_ZERO && u != FMT_POSINT)
 589         {
 590           error = nonneg_required;
 591           goto syntax;
 592         }
 593
 594       if (t == FMT_D)
 595         break;
 596
 597       /* Look for optional exponent.  */
 598       u = format_lex ();
 599       if (u != FMT_E)
 600         {
 601           saved_token = u;
 602         }
 603       else
 604         {
 605           u = format_lex ();
 606           if (u != FMT_POSINT)
 607             {
 608               error = "Positive exponent width required";
 609               goto syntax;
 610             }
 611         }
 612
 613       break;
 614
 615     case FMT_F:
 616       t = format_lex ();
 617       if (t != FMT_ZERO && t != FMT_POSINT)
 618         {
 619           error = nonneg_required;
 620           goto syntax;
 621         }
 622
 623       t = format_lex ();
 624       if (t != FMT_PERIOD)
 625         {
 626           error = period_required;
 627           goto syntax;
 628         }
 629
 630       t = format_lex ();
 631       if (t != FMT_ZERO && t != FMT_POSINT)
 632         {
 633           error = nonneg_required;
 634           goto syntax;
 635         }
 636
 637       break;
 638
 639     case FMT_H:
 640       if(mode == MODE_STRING)
 641       {
 642         format_string += value;
 643         format_length -= value;
 644       }
 645       else
 646       {
 647         while(repeat >0)
 648          {
 649           next_char(1);
 650           repeat -- ;
 651          }
 652       }
 653      break;
 654
 655     case FMT_IBOZ:
 656       t = format_lex ();
 657       if (t != FMT_ZERO && t != FMT_POSINT)
 658         {
 659           error = nonneg_required;
 660           goto syntax;
 661         }
 662
 663       t = format_lex ();
 664       if (t != FMT_PERIOD)
 665         {
 666           saved_token = t;
 667         }
 668       else
 669         {
 670           t = format_lex ();
 671           if (t != FMT_ZERO && t != FMT_POSINT)
 672             {
 673               error = nonneg_required;
 674               goto syntax;
 675             }
 676         }
 677
 678       break;
 679
 680     default:
 681       error = unexpected_element;
 682       goto syntax;
 683     }
 684
 685 between_desc:
 686   /* Between a descriptor and what comes next.  */
 687   t = format_lex ();
 688   switch (t)
 689     {
 690
 691     case FMT_COMMA:
 692       goto format_item;
 693
 694     case FMT_RPAREN:
 695       level--;
 696       if (level < 0)
 697         goto finished;
 698       goto between_desc;
 699
 700     case FMT_COLON:
 701     case FMT_SLASH:
 702       goto optional_comma;
 703
 704     case FMT_END:
 705       error = unexpected_end;
 706       goto syntax;
 707
 708     default:
 709       if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
 710           == FAILURE)
 711         return FAILURE;
 712       goto format_item_1;
 713     }
 714
 715 optional_comma:
 716   /* Optional comma is a weird between state where we've just finished
 717      reading a colon, slash or P descriptor.  */
 718   t = format_lex ();
 719   switch (t)
 720     {
 721     case FMT_COMMA:
 722       break;
 723
 724     case FMT_RPAREN:
 725       level--;
 726       if (level < 0)
 727         goto finished;
 728       goto between_desc;
 729
 730     default:
 731       /* Assume that we have another format item.  */
 732       saved_token = t;
 733       break;
 734     }
 735
 736   goto format_item;
 737
 738 extension_optional_comma:
 739   /* As a GNU extension, permit a missing comma after a string literal.  */
 740   t = format_lex ();
 741   switch (t)
 742     {
 743     case FMT_COMMA:
 744       break;
 745
 746     case FMT_RPAREN:
 747       level--;
 748       if (level < 0)
 749         goto finished;
 750       goto between_desc;
 751
 752     case FMT_COLON:
 753     case FMT_SLASH:
 754       goto optional_comma;
 755
 756     case FMT_END:
 757       error = unexpected_end;
 758       goto syntax;
 759
 760     default:
 761       if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
 762           == FAILURE)
 763         return FAILURE;
 764       saved_token = t;
 765       break;
 766     }
 767
 768   goto format_item;
 769
 770 syntax:
 771   /* Something went wrong.  If the format we're checking is a string,
 772      generate a warning, since the program is correct.  If the format
 773      is in a FORMAT statement, this messes up parsing, which is an
 774      error.  */
 775   if (mode != MODE_STRING)
 776     gfc_error ("%s in format string at %C", error);
 777   else
 778     {
 779       gfc_warning ("%s in format string at %C", error);
 780
 781       /* TODO: More elaborate measures are needed to show where a problem
 782          is within a format string that has been calculated.  */
 783     }
 784
 785   rv = FAILURE;
 786
 787 finished:
 788   return rv;
 789 }
 790
 791
 792 /* Given an expression node that is a constant string, see if it looks
 793    like a format string.  */
 794
 795 static void
 796 check_format_string (gfc_expr * e)
 797 {
 798
 799   mode = MODE_STRING;
 800   format_string = e->value.character.string;
 801   check_format ();
 802 }
 803
 804
 805 /************ Fortran 95 I/O statement matchers *************/
 806
 807 /* Match a FORMAT statement.  This amounts to actually parsing the
 808    format descriptors in order to correctly locate the end of the
 809    format string.  */
 810
 811 match
 812 gfc_match_format (void)
 813 {
 814   gfc_expr *e;
 815   locus start;
 816
 817   if (gfc_statement_label == NULL)
 818     {
 819       gfc_error ("Missing format label at %C");
 820       return MATCH_ERROR;
 821     }
 822   gfc_gobble_whitespace ();
 823
 824   mode = MODE_FORMAT;
 825   format_length = 0;
 826
 827   start = gfc_current_locus;
 828
 829   if (check_format () == FAILURE)
 830     return MATCH_ERROR;
 831
 832   if (gfc_match_eos () != MATCH_YES)
 833     {
 834       gfc_syntax_error (ST_FORMAT);
 835       return MATCH_ERROR;
 836     }
 837
 838   /* The label doesn't get created until after the statement is done
 839      being matched, so we have to leave the string for later.  */
 840
 841   gfc_current_locus = start;    /* Back to the beginning */
 842
 843   new_st.loc = start;
 844   new_st.op = EXEC_NOP;
 845
 846   e = gfc_get_expr();
 847   e->expr_type = EXPR_CONSTANT;
 848   e->ts.type = BT_CHARACTER;
 849   e->ts.kind = gfc_default_character_kind;
 850   e->where = start;
 851   e->value.character.string = format_string = gfc_getmem(format_length+1);
 852   e->value.character.length = format_length;
 853   gfc_statement_label->format = e;
 854
 855   mode = MODE_COPY;
 856   check_format ();              /* Guaranteed to succeed */
 857   gfc_match_eos ();             /* Guaranteed to succeed */
 858
 859   return MATCH_YES;
 860 }
 861
 862
 863 /* Match an expression I/O tag of some sort.  */
 864
 865 static match
 866 match_etag (const io_tag * tag, gfc_expr ** v)
 867 {
 868   gfc_expr *result;
 869   match m;
 870
 871   m = gfc_match (tag->spec, &result);
 872   if (m != MATCH_YES)
 873     return m;
 874
 875   if (*v != NULL)
 876     {
 877       gfc_error ("Duplicate %s specification at %C", tag->name);
 878       gfc_free_expr (result);
 879       return MATCH_ERROR;
 880     }
 881
 882   *v = result;
 883   return MATCH_YES;
 884 }
 885
 886
 887 /* Match a variable I/O tag of some sort.  */
 888
 889 static match
 890 match_vtag (const io_tag * tag, gfc_expr ** v)
 891 {
 892   gfc_expr *result;
 893   match m;
 894
 895   m = gfc_match (tag->spec, &result);
 896   if (m != MATCH_YES)
 897     return m;
 898
 899   if (*v != NULL)
 900     {
 901       gfc_error ("Duplicate %s specification at %C", tag->name);
 902       gfc_free_expr (result);
 903       return MATCH_ERROR;
 904     }
 905
 906   if (result->symtree->n.sym->attr.intent == INTENT_IN)
 907     {
 908       gfc_error ("Variable tag cannot be INTENT(IN) at %C");
 909       gfc_free_expr (result);
 910       return MATCH_ERROR;
 911     }
 912
 913   if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
 914     {
 915       gfc_error ("Variable tag cannot be assigned in PURE procedure at %C");
 916       gfc_free_expr (result);
 917       return MATCH_ERROR;
 918     }
 919
 920   *v = result;
 921   return MATCH_YES;
 922 }
 923
 924
 925 /* Match I/O tags that cause variables to become redefined.  */
 926
 927 static match
 928 match_out_tag(const io_tag *tag, gfc_expr **result)
 929 {
 930   match m;
 931
 932   m = match_vtag(tag, result);
 933   if (m == MATCH_YES)
 934     gfc_check_do_variable((*result)->symtree);
 935
 936   return m;
 937 }
 938
 939
 940 /* Match a label I/O tag.  */
 941
 942 static match
 943 match_ltag (const io_tag * tag, gfc_st_label ** label)
 944 {
 945   match m;
 946   gfc_st_label *old;
 947
 948   old = *label;
 949   m = gfc_match (tag->spec, label);
 950   if (m == MATCH_YES && old != 0)
 951     {
 952       gfc_error ("Duplicate %s label specification at %C", tag->name);
 953       return MATCH_ERROR;
 954     }
 955
 956   return m;
 957 }
 958
 959
 960 /* Do expression resolution and type-checking on an expression tag.  */
 961
 962 static try
 963 resolve_tag (const io_tag * tag, gfc_expr * e)
 964 {
 965
 966   if (e == NULL)
 967     return SUCCESS;
 968
 969   if (gfc_resolve_expr (e) == FAILURE)
 970     return FAILURE;
 971
 972   if (e->ts.type != tag->type && tag != &tag_format)
 973     {
 974       gfc_error ("%s tag at %L must be of type %s", tag->name,
 975                 &e->where, gfc_basic_typename (tag->type));
 976       return FAILURE;
 977     }
 978
 979   if (tag == &tag_format)
 980     {
 981       /* If e's rank is zero and e is not an element of an array, it should be
 982          of integer or character type.  The integer variable should be
 983          ASSIGNED.  */
 984       if (e->symtree == NULL || e->symtree->n.sym->as == NULL
 985                 || e->symtree->n.sym->as->rank == 0)
 986         {
 987           if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
 988             {
 989               gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
 990                         &e->where, gfc_basic_typename (BT_CHARACTER),
 991                         gfc_basic_typename (BT_INTEGER));
 992               return FAILURE;
 993             }
 994           else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
 995             {
 996               if (gfc_notify_std (GFC_STD_F95_DEL,
 997                         "Obsolete: ASSIGNED variable in FORMAT tag at %L",
 998                         &e->where) == FAILURE)
 999                 return FAILURE;
1000               if (e->symtree->n.sym->attr.assign != 1)
1001                 {
1002                   gfc_error ("Variable '%s' at %L has not been assigned a "
1003                         "format label", e->symtree->n.sym->name, &e->where);
1004                   return FAILURE;
1005                 }
1006             }
1007           return SUCCESS;
1008         }
1009       else
1010         {
1011           /* if rank is nonzero, we allow the type to be character under
1012              GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
1013              assigned an Hollerith constant.  */
1014           if (e->ts.type == BT_CHARACTER)
1015             {
1016               if (gfc_notify_std (GFC_STD_GNU,
1017                         "Extension: Character array in FORMAT tag at %L",
1018                         &e->where) == FAILURE)
1019                 return FAILURE;
1020             }
1021           else
1022             {
1023               if (gfc_notify_std (GFC_STD_LEGACY,
1024                         "Extension: Non-character in FORMAT tag at %L",
1025                         &e->where) == FAILURE)
1026                 return FAILURE;
1027             }
1028           return SUCCESS;
1029         }
1030     }
1031   else
1032     {
1033       if (e->rank != 0)
1034         {
1035           gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1036           return FAILURE;
1037         }
1038     }
1039
1040   return SUCCESS;
1041 }
1042
1043
1044 /* Match a single tag of an OPEN statement.  */
1045
1046 static match
1047 match_open_element (gfc_open * open)
1048 {
1049   match m;
1050
1051   m = match_etag (&tag_unit, &open->unit);
1052   if (m != MATCH_NO)
1053     return m;
1054   m = match_out_tag (&tag_iostat, &open->iostat);
1055   if (m != MATCH_NO)
1056     return m;
1057   m = match_etag (&tag_file, &open->file);
1058   if (m != MATCH_NO)
1059     return m;
1060   m = match_etag (&tag_status, &open->status);
1061   if (m != MATCH_NO)
1062     return m;
1063   m = match_etag (&tag_e_access, &open->access);
1064   if (m != MATCH_NO)
1065     return m;
1066   m = match_etag (&tag_e_form, &open->form);
1067   if (m != MATCH_NO)
1068     return m;
1069   m = match_etag (&tag_e_recl, &open->recl);
1070   if (m != MATCH_NO)
1071     return m;
1072   m = match_etag (&tag_e_blank, &open->blank);
1073   if (m != MATCH_NO)
1074     return m;
1075   m = match_etag (&tag_e_position, &open->position);
1076   if (m != MATCH_NO)
1077     return m;
1078   m = match_etag (&tag_e_action, &open->action);
1079   if (m != MATCH_NO)
1080     return m;
1081   m = match_etag (&tag_e_delim, &open->delim);
1082   if (m != MATCH_NO)
1083     return m;
1084   m = match_etag (&tag_e_pad, &open->pad);
1085   if (m != MATCH_NO)
1086     return m;
1087   m = match_ltag (&tag_err, &open->err);
1088   if (m != MATCH_NO)
1089     return m;
1090
1091   return MATCH_NO;
1092 }
1093
1094
1095 /* Free the gfc_open structure and all the expressions it contains.  */
1096
1097 void
1098 gfc_free_open (gfc_open * open)
1099 {
1100
1101   if (open == NULL)
1102     return;
1103
1104   gfc_free_expr (open->unit);
1105   gfc_free_expr (open->iostat);
1106   gfc_free_expr (open->file);
1107   gfc_free_expr (open->status);
1108   gfc_free_expr (open->access);
1109   gfc_free_expr (open->form);
1110   gfc_free_expr (open->recl);
1111   gfc_free_expr (open->blank);
1112   gfc_free_expr (open->position);
1113   gfc_free_expr (open->action);
1114   gfc_free_expr (open->delim);
1115   gfc_free_expr (open->pad);
1116
1117   gfc_free (open);
1118 }
1119
1120
1121 /* Resolve everything in a gfc_open structure.  */
1122
1123 try
1124 gfc_resolve_open (gfc_open * open)
1125 {
1126
1127   RESOLVE_TAG (&tag_unit, open->unit);
1128   RESOLVE_TAG (&tag_iostat, open->iostat);
1129   RESOLVE_TAG (&tag_file, open->file);
1130   RESOLVE_TAG (&tag_status, open->status);
1131   RESOLVE_TAG (&tag_e_form, open->form);
1132   RESOLVE_TAG (&tag_e_recl, open->recl);
1133
1134   RESOLVE_TAG (&tag_e_blank, open->blank);
1135   RESOLVE_TAG (&tag_e_position, open->position);
1136   RESOLVE_TAG (&tag_e_action, open->action);
1137   RESOLVE_TAG (&tag_e_delim, open->delim);
1138   RESOLVE_TAG (&tag_e_pad, open->pad);
1139
1140   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1141     return FAILURE;
1142
1143   return SUCCESS;
1144 }
1145
1146
1147 /* Match an OPEN statement.  */
1148
1149 match
1150 gfc_match_open (void)
1151 {
1152   gfc_open *open;
1153   match m;
1154
1155   m = gfc_match_char ('(');
1156   if (m == MATCH_NO)
1157     return m;
1158
1159   open = gfc_getmem (sizeof (gfc_open));
1160
1161   m = match_open_element (open);
1162
1163   if (m == MATCH_ERROR)
1164     goto cleanup;
1165   if (m == MATCH_NO)
1166     {
1167       m = gfc_match_expr (&open->unit);
1168       if (m == MATCH_NO)
1169         goto syntax;
1170       if (m == MATCH_ERROR)
1171         goto cleanup;
1172     }
1173
1174   for (;;)
1175     {
1176       if (gfc_match_char (')') == MATCH_YES)
1177         break;
1178       if (gfc_match_char (',') != MATCH_YES)
1179         goto syntax;
1180
1181       m = match_open_element (open);
1182       if (m == MATCH_ERROR)
1183         goto cleanup;
1184       if (m == MATCH_NO)
1185         goto syntax;
1186     }
1187
1188   if (gfc_match_eos () == MATCH_NO)
1189     goto syntax;
1190
1191   if (gfc_pure (NULL))
1192     {
1193       gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1194       goto cleanup;
1195     }
1196
1197   new_st.op = EXEC_OPEN;
1198   new_st.ext.open = open;
1199   return MATCH_YES;
1200
1201 syntax:
1202   gfc_syntax_error (ST_OPEN);
1203
1204 cleanup:
1205   gfc_free_open (open);
1206   return MATCH_ERROR;
1207 }
1208
1209
1210 /* Free a gfc_close structure an all its expressions.  */
1211
1212 void
1213 gfc_free_close (gfc_close * close)
1214 {
1215
1216   if (close == NULL)
1217     return;
1218
1219   gfc_free_expr (close->unit);
1220   gfc_free_expr (close->iostat);
1221   gfc_free_expr (close->status);
1222
1223   gfc_free (close);
1224 }
1225
1226
1227 /* Match elements of a CLOSE statement.  */
1228
1229 static match
1230 match_close_element (gfc_close * close)
1231 {
1232   match m;
1233
1234   m = match_etag (&tag_unit, &close->unit);
1235   if (m != MATCH_NO)
1236     return m;
1237   m = match_etag (&tag_status, &close->status);
1238   if (m != MATCH_NO)
1239     return m;
1240   m = match_out_tag (&tag_iostat, &close->iostat);
1241   if (m != MATCH_NO)
1242     return m;
1243   m = match_ltag (&tag_err, &close->err);
1244   if (m != MATCH_NO)
1245     return m;
1246
1247   return MATCH_NO;
1248 }
1249
1250
1251 /* Match a CLOSE statement.  */
1252
1253 match
1254 gfc_match_close (void)
1255 {
1256   gfc_close *close;
1257   match m;
1258
1259   m = gfc_match_char ('(');
1260   if (m == MATCH_NO)
1261     return m;
1262
1263   close = gfc_getmem (sizeof (gfc_close));
1264
1265   m = match_close_element (close);
1266
1267   if (m == MATCH_ERROR)
1268     goto cleanup;
1269   if (m == MATCH_NO)
1270     {
1271       m = gfc_match_expr (&close->unit);
1272       if (m == MATCH_NO)
1273         goto syntax;
1274       if (m == MATCH_ERROR)
1275         goto cleanup;
1276     }
1277
1278   for (;;)
1279     {
1280       if (gfc_match_char (')') == MATCH_YES)
1281         break;
1282       if (gfc_match_char (',') != MATCH_YES)
1283         goto syntax;
1284
1285       m = match_close_element (close);
1286       if (m == MATCH_ERROR)
1287         goto cleanup;
1288       if (m == MATCH_NO)
1289         goto syntax;
1290     }
1291
1292   if (gfc_match_eos () == MATCH_NO)
1293     goto syntax;
1294
1295   if (gfc_pure (NULL))
1296     {
1297       gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
1298       goto cleanup;
1299     }
1300
1301   new_st.op = EXEC_CLOSE;
1302   new_st.ext.close = close;
1303   return MATCH_YES;
1304
1305 syntax:
1306   gfc_syntax_error (ST_CLOSE);
1307
1308 cleanup:
1309   gfc_free_close (close);
1310   return MATCH_ERROR;
1311 }
1312
1313
1314 /* Resolve everything in a gfc_close structure.  */
1315
1316 try
1317 gfc_resolve_close (gfc_close * close)
1318 {
1319
1320   RESOLVE_TAG (&tag_unit, close->unit);
1321   RESOLVE_TAG (&tag_iostat, close->iostat);
1322   RESOLVE_TAG (&tag_status, close->status);
1323
1324   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
1325     return FAILURE;
1326
1327   return SUCCESS;
1328 }
1329
1330
1331 /* Free a gfc_filepos structure.  */
1332
1333 void
1334 gfc_free_filepos (gfc_filepos * fp)
1335 {
1336
1337   gfc_free_expr (fp->unit);
1338   gfc_free_expr (fp->iostat);
1339   gfc_free (fp);
1340 }
1341
1342
1343 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
1344
1345 static match
1346 match_file_element (gfc_filepos * fp)
1347 {
1348   match m;
1349
1350   m = match_etag (&tag_unit, &fp->unit);
1351   if (m != MATCH_NO)
1352     return m;
1353   m = match_out_tag (&tag_iostat, &fp->iostat);
1354   if (m != MATCH_NO)
1355     return m;
1356   m = match_ltag (&tag_err, &fp->err);
1357   if (m != MATCH_NO)
1358     return m;
1359
1360   return MATCH_NO;
1361 }
1362
1363
1364 /* Match the second half of the file-positioning statements, REWIND,
1365    BACKSPACE, ENDFILE, or the FLUSH statement.  */
1366
1367 static match
1368 match_filepos (gfc_statement st, gfc_exec_op op)
1369 {
1370   gfc_filepos *fp;
1371   match m;
1372
1373   fp = gfc_getmem (sizeof (gfc_filepos));
1374
1375   if (gfc_match_char ('(') == MATCH_NO)
1376     {
1377       m = gfc_match_expr (&fp->unit);
1378       if (m == MATCH_ERROR)
1379         goto cleanup;
1380       if (m == MATCH_NO)
1381         goto syntax;
1382
1383       goto done;
1384     }
1385
1386   m = match_file_element (fp);
1387   if (m == MATCH_ERROR)
1388     goto done;
1389   if (m == MATCH_NO)
1390     {
1391       m = gfc_match_expr (&fp->unit);
1392       if (m == MATCH_ERROR)
1393         goto done;
1394       if (m == MATCH_NO)
1395         goto syntax;
1396     }
1397
1398   for (;;)
1399     {
1400       if (gfc_match_char (')') == MATCH_YES)
1401         break;
1402       if (gfc_match_char (',') != MATCH_YES)
1403         goto syntax;
1404
1405       m = match_file_element (fp);
1406       if (m == MATCH_ERROR)
1407         goto cleanup;
1408       if (m == MATCH_NO)
1409         goto syntax;
1410     }
1411
1412 done:
1413   if (gfc_match_eos () != MATCH_YES)
1414     goto syntax;
1415
1416   if (gfc_pure (NULL))
1417     {
1418       gfc_error ("%s statement not allowed in PURE procedure at %C",
1419                  gfc_ascii_statement (st));
1420
1421       goto cleanup;
1422     }
1423
1424   new_st.op = op;
1425   new_st.ext.filepos = fp;
1426   return MATCH_YES;
1427
1428 syntax:
1429   gfc_syntax_error (st);
1430
1431 cleanup:
1432   gfc_free_filepos (fp);
1433   return MATCH_ERROR;
1434 }
1435
1436
1437 try
1438 gfc_resolve_filepos (gfc_filepos * fp)
1439 {
1440
1441   RESOLVE_TAG (&tag_unit, fp->unit);
1442   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
1443     return FAILURE;
1444
1445   return SUCCESS;
1446 }
1447
1448
1449 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
1450    and the FLUSH statement.  */
1451
1452 match
1453 gfc_match_endfile (void)
1454 {
1455
1456   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
1457 }
1458
1459 match
1460 gfc_match_backspace (void)
1461 {
1462
1463   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
1464 }
1465
1466 match
1467 gfc_match_rewind (void)
1468 {
1469
1470   return match_filepos (ST_REWIND, EXEC_REWIND);
1471 }
1472
1473 match
1474 gfc_match_flush (void)
1475 {
1476   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C") == FAILURE)
1477     return MATCH_ERROR;
1478
1479   return match_filepos (ST_FLUSH, EXEC_FLUSH);
1480 }
1481
1482 /******************** Data Transfer Statements *********************/
1483
1484 typedef enum
1485 { M_READ, M_WRITE, M_PRINT, M_INQUIRE }
1486 io_kind;
1487
1488
1489 /* Return a default unit number.  */
1490
1491 static gfc_expr *
1492 default_unit (io_kind k)
1493 {
1494   int unit;
1495
1496   if (k == M_READ)
1497     unit = 5;
1498   else
1499     unit = 6;
1500
1501   return gfc_int_expr (unit);
1502 }
1503
1504
1505 /* Match a unit specification for a data transfer statement.  */
1506
1507 static match
1508 match_dt_unit (io_kind k, gfc_dt * dt)
1509 {
1510   gfc_expr *e;
1511
1512   if (gfc_match_char ('*') == MATCH_YES)
1513     {
1514       if (dt->io_unit != NULL)
1515         goto conflict;
1516
1517       dt->io_unit = default_unit (k);
1518       return MATCH_YES;
1519     }
1520
1521   if (gfc_match_expr (&e) == MATCH_YES)
1522     {
1523       if (dt->io_unit != NULL)
1524         {
1525           gfc_free_expr (e);
1526           goto conflict;
1527         }
1528
1529       dt->io_unit = e;
1530       return MATCH_YES;
1531     }
1532
1533   return MATCH_NO;
1534
1535 conflict:
1536   gfc_error ("Duplicate UNIT specification at %C");
1537   return MATCH_ERROR;
1538 }
1539
1540
1541 /* Match a format specification.  */
1542
1543 static match
1544 match_dt_format (gfc_dt * dt)
1545 {
1546   locus where;
1547   gfc_expr *e;
1548   gfc_st_label *label;
1549
1550   where = gfc_current_locus;
1551
1552   if (gfc_match_char ('*') == MATCH_YES)
1553     {
1554       if (dt->format_expr != NULL || dt->format_label != NULL)
1555         goto conflict;
1556
1557       dt->format_label = &format_asterisk;
1558       return MATCH_YES;
1559     }
1560
1561   if (gfc_match_st_label (&label, 0) == MATCH_YES)
1562     {
1563       if (dt->format_expr != NULL || dt->format_label != NULL)
1564         {
1565           gfc_free_st_label (label);
1566           goto conflict;
1567         }
1568
1569       if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
1570         return MATCH_ERROR;
1571
1572       dt->format_label = label;
1573       return MATCH_YES;
1574     }
1575
1576   if (gfc_match_expr (&e) == MATCH_YES)
1577     {
1578       if (dt->format_expr != NULL || dt->format_label != NULL)
1579         {
1580           gfc_free_expr (e);
1581           goto conflict;
1582         }
1583       dt->format_expr = e;
1584       return MATCH_YES;
1585     }
1586
1587   gfc_current_locus = where;    /* The only case where we have to restore */
1588
1589   return MATCH_NO;
1590
1591 conflict:
1592   gfc_error ("Duplicate format specification at %C");
1593   return MATCH_ERROR;
1594 }
1595
1596
1597 /* Traverse a namelist that is part of a READ statement to make sure
1598    that none of the variables in the namelist are INTENT(IN).  Returns
1599    nonzero if we find such a variable.  */
1600
1601 static int
1602 check_namelist (gfc_symbol * sym)
1603 {
1604   gfc_namelist *p;
1605
1606   for (p = sym->namelist; p; p = p->next)
1607     if (p->sym->attr.intent == INTENT_IN)
1608       {
1609         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
1610                    p->sym->name, sym->name);
1611         return 1;
1612       }
1613
1614   return 0;
1615 }
1616
1617
1618 /* Match a single data transfer element.  */
1619
1620 static match
1621 match_dt_element (io_kind k, gfc_dt * dt)
1622 {
1623   char name[GFC_MAX_SYMBOL_LEN + 1];
1624   gfc_symbol *sym;
1625   match m;
1626
1627   if (gfc_match (" unit =") == MATCH_YES)
1628     {
1629       m = match_dt_unit (k, dt);
1630       if (m != MATCH_NO)
1631         return m;
1632     }
1633
1634   if (gfc_match (" fmt =") == MATCH_YES)
1635     {
1636       m = match_dt_format (dt);
1637       if (m != MATCH_NO)
1638         return m;
1639     }
1640
1641   if (gfc_match (" nml = %n", name) == MATCH_YES)
1642     {
1643       if (dt->namelist != NULL)
1644         {
1645           gfc_error ("Duplicate NML specification at %C");
1646           return MATCH_ERROR;
1647         }
1648
1649       if (gfc_find_symbol (name, NULL, 1, &sym))
1650         return MATCH_ERROR;
1651
1652       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
1653         {
1654           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
1655                      sym != NULL ? sym->name : name);
1656           return MATCH_ERROR;
1657         }
1658
1659       dt->namelist = sym;
1660       if (k == M_READ && check_namelist (sym))
1661         return MATCH_ERROR;
1662
1663       return MATCH_YES;
1664     }
1665
1666   m = match_etag (&tag_rec, &dt->rec);
1667   if (m != MATCH_NO)
1668     return m;
1669   m = match_out_tag (&tag_iostat, &dt->iostat);
1670   if (m != MATCH_NO)
1671     return m;
1672   m = match_ltag (&tag_err, &dt->err);
1673   if (m != MATCH_NO)
1674     return m;
1675   m = match_etag (&tag_advance, &dt->advance);
1676   if (m != MATCH_NO)
1677     return m;
1678   m = match_out_tag (&tag_size, &dt->size);
1679   if (m != MATCH_NO)
1680     return m;
1681
1682   m = match_ltag (&tag_end, &dt->end);
1683   if (m == MATCH_YES)
1684     {
1685       if (k == M_WRITE)
1686        {
1687          gfc_error ("END tag at %C not allowed in output statement");
1688          return MATCH_ERROR;
1689        }
1690       dt->end_where = gfc_current_locus;
1691     }
1692   if (m != MATCH_NO)
1693     return m;
1694
1695   m = match_ltag (&tag_eor, &dt->eor);
1696   if (m == MATCH_YES)
1697     dt->eor_where = gfc_current_locus;
1698   if (m != MATCH_NO)
1699     return m;
1700
1701   return MATCH_NO;
1702 }
1703
1704
1705 /* Free a data transfer structure and everything below it.  */
1706
1707 void
1708 gfc_free_dt (gfc_dt * dt)
1709 {
1710
1711   if (dt == NULL)
1712     return;
1713
1714   gfc_free_expr (dt->io_unit);
1715   gfc_free_expr (dt->format_expr);
1716   gfc_free_expr (dt->rec);
1717   gfc_free_expr (dt->advance);
1718   gfc_free_expr (dt->iostat);
1719   gfc_free_expr (dt->size);
1720
1721   gfc_free (dt);
1722 }
1723
1724
1725 /* Resolve everything in a gfc_dt structure.  */
1726
1727 try
1728 gfc_resolve_dt (gfc_dt * dt)
1729 {
1730   gfc_expr *e;
1731
1732   RESOLVE_TAG (&tag_format, dt->format_expr);
1733   RESOLVE_TAG (&tag_rec, dt->rec);
1734   RESOLVE_TAG (&tag_advance, dt->advance);
1735   RESOLVE_TAG (&tag_iostat, dt->iostat);
1736   RESOLVE_TAG (&tag_size, dt->size);
1737
1738   e = dt->io_unit;
1739   if (gfc_resolve_expr (e) == SUCCESS
1740       && (e->ts.type != BT_INTEGER
1741           && (e->ts.type != BT_CHARACTER
1742               || e->expr_type != EXPR_VARIABLE)))
1743     {
1744       gfc_error
1745         ("UNIT specification at %L must be an INTEGER expression or a "
1746          "CHARACTER variable", &e->where);
1747       return FAILURE;
1748     }
1749
1750   /* Sanity checks on data transfer statements.  */
1751   if (e->ts.type == BT_CHARACTER)
1752     {
1753       if (dt->rec != NULL)
1754         {
1755           gfc_error ("REC tag at %L is incompatible with internal file",
1756                      &dt->rec->where);
1757           return FAILURE;
1758         }
1759
1760       if (dt->namelist != NULL)
1761         {
1762           gfc_error ("Internal file at %L is incompatible with namelist",
1763                      &dt->io_unit->where);
1764           return FAILURE;
1765         }
1766
1767       if (dt->advance != NULL)
1768         {
1769           gfc_error ("ADVANCE tag at %L is incompatible with internal file",
1770                      &dt->advance->where);
1771           return FAILURE;
1772         }
1773     }
1774
1775   if (dt->rec != NULL)
1776     {
1777       if (dt->end != NULL)
1778         {
1779           gfc_error ("REC tag at %L is incompatible with END tag",
1780                      &dt->rec->where);
1781           return FAILURE;
1782         }
1783
1784       if (dt->format_label == &format_asterisk)
1785         {
1786           gfc_error
1787             ("END tag at %L is incompatible with list directed format (*)",
1788              &dt->end_where);
1789           return FAILURE;
1790         }
1791
1792       if (dt->namelist != NULL)
1793         {
1794           gfc_error ("REC tag at %L is incompatible with namelist",
1795                      &dt->rec->where);
1796           return FAILURE;
1797         }
1798     }
1799
1800   if (dt->advance != NULL && dt->format_label == &format_asterisk)
1801     {
1802       gfc_error ("ADVANCE tag at %L is incompatible with list directed "
1803                  "format (*)", &dt->advance->where);
1804       return FAILURE;
1805     }
1806
1807   if (dt->eor != 0 && dt->advance == NULL)
1808     {
1809       gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt->eor_where);
1810       return FAILURE;
1811     }
1812
1813   if (dt->size != NULL && dt->advance == NULL)
1814     {
1815       gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt->size->where);
1816       return FAILURE;
1817     }
1818
1819   /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string
1820      constant.  */
1821
1822   if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
1823     return FAILURE;
1824
1825   if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
1826     return FAILURE;
1827
1828   if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
1829     return FAILURE;
1830
1831   /* Check the format label actually exists.  */
1832   if (dt->format_label && dt->format_label != &format_asterisk
1833       && dt->format_label->defined == ST_LABEL_UNKNOWN)
1834     {
1835       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
1836                  &dt->format_label->where);
1837       return FAILURE;
1838     }
1839   return SUCCESS;
1840 }
1841
1842
1843 /* Given an io_kind, return its name.  */
1844
1845 static const char *
1846 io_kind_name (io_kind k)
1847 {
1848   const char *name;
1849
1850   switch (k)
1851     {
1852     case M_READ:
1853       name = "READ";
1854       break;
1855     case M_WRITE:
1856       name = "WRITE";
1857       break;
1858     case M_PRINT:
1859       name = "PRINT";
1860       break;
1861     case M_INQUIRE:
1862       name = "INQUIRE";
1863       break;
1864     default:
1865       gfc_internal_error ("io_kind_name(): bad I/O-kind");
1866     }
1867
1868   return name;
1869 }
1870
1871
1872 /* Match an IO iteration statement of the form:
1873
1874    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
1875
1876    which is equivalent to a single IO element.  This function is
1877    mutually recursive with match_io_element().  */
1878
1879 static match match_io_element (io_kind k, gfc_code **);
1880
1881 static match
1882 match_io_iterator (io_kind k, gfc_code ** result)
1883 {
1884   gfc_code *head, *tail, *new;
1885   gfc_iterator *iter;
1886   locus old_loc;
1887   match m;
1888   int n;
1889
1890   iter = NULL;
1891   head = NULL;
1892   old_loc = gfc_current_locus;
1893
1894   if (gfc_match_char ('(') != MATCH_YES)
1895     return MATCH_NO;
1896
1897   m = match_io_element (k, &head);
1898   tail = head;
1899
1900   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
1901     {
1902       m = MATCH_NO;
1903       goto cleanup;
1904     }
1905
1906   /* Can't be anything but an IO iterator.  Build a list.  */
1907   iter = gfc_get_iterator ();
1908
1909   for (n = 1;; n++)
1910     {
1911       m = gfc_match_iterator (iter, 0);
1912       if (m == MATCH_ERROR)
1913         goto cleanup;
1914       if (m == MATCH_YES)
1915         {
1916           gfc_check_do_variable (iter->var->symtree);
1917           break;
1918         }
1919
1920       m = match_io_element (k, &new);
1921       if (m == MATCH_ERROR)
1922         goto cleanup;
1923       if (m == MATCH_NO)
1924         {
1925           if (n > 2)
1926             goto syntax;
1927           goto cleanup;
1928         }
1929
1930       tail = gfc_append_code (tail, new);
1931
1932       if (gfc_match_char (',') != MATCH_YES)
1933         {
1934           if (n > 2)
1935             goto syntax;
1936           m = MATCH_NO;
1937           goto cleanup;
1938         }
1939     }
1940
1941   if (gfc_match_char (')') != MATCH_YES)
1942     goto syntax;
1943
1944   new = gfc_get_code ();
1945   new->op = EXEC_DO;
1946   new->ext.iterator = iter;
1947
1948   new->block = gfc_get_code ();
1949   new->block->op = EXEC_DO;
1950   new->block->next = head;
1951
1952   *result = new;
1953   return MATCH_YES;
1954
1955 syntax:
1956   gfc_error ("Syntax error in I/O iterator at %C");
1957   m = MATCH_ERROR;
1958
1959 cleanup:
1960   gfc_free_iterator (iter, 1);
1961   gfc_free_statements (head);
1962   gfc_current_locus = old_loc;
1963   return m;
1964 }
1965
1966
1967 /* Match a single element of an IO list, which is either a single
1968    expression or an IO Iterator.  */
1969
1970 static match
1971 match_io_element (io_kind k, gfc_code ** cpp)
1972 {
1973   gfc_expr *expr;
1974   gfc_code *cp;
1975   match m;
1976
1977   expr = NULL;
1978
1979   m = match_io_iterator (k, cpp);
1980   if (m == MATCH_YES)
1981     return MATCH_YES;
1982
1983   if (k == M_READ)
1984     {
1985       m = gfc_match_variable (&expr, 0);
1986       if (m == MATCH_NO)
1987         gfc_error ("Expected variable in READ statement at %C");
1988     }
1989   else
1990     {
1991       m = gfc_match_expr (&expr);
1992       if (m == MATCH_NO)
1993         gfc_error ("Expected expression in %s statement at %C",
1994                    io_kind_name (k));
1995     }
1996
1997   if (m == MATCH_YES)
1998     switch (k)
1999       {
2000       case M_READ:
2001         if (expr->symtree->n.sym->attr.intent == INTENT_IN)
2002           {
2003             gfc_error
2004               ("Variable '%s' in input list at %C cannot be INTENT(IN)",
2005                expr->symtree->n.sym->name);
2006             m = MATCH_ERROR;
2007           }
2008
2009         if (gfc_pure (NULL)
2010             && gfc_impure_variable (expr->symtree->n.sym)
2011             && current_dt->io_unit->ts.type == BT_CHARACTER)
2012           {
2013             gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
2014                        expr->symtree->n.sym->name);
2015             m = MATCH_ERROR;
2016           }
2017
2018         if (gfc_check_do_variable (expr->symtree))
2019           m = MATCH_ERROR;
2020
2021         break;
2022
2023       case M_WRITE:
2024         if (current_dt->io_unit->ts.type == BT_CHARACTER
2025             && gfc_pure (NULL)
2026             && current_dt->io_unit->expr_type == EXPR_VARIABLE
2027             && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
2028           {
2029             gfc_error
2030               ("Cannot write to internal file unit '%s' at %C inside a "
2031                "PURE procedure", current_dt->io_unit->symtree->n.sym->name);
2032             m = MATCH_ERROR;
2033           }
2034
2035         break;
2036
2037       default:
2038         break;
2039       }
2040
2041   if (m != MATCH_YES)
2042     {
2043       gfc_free_expr (expr);
2044       return MATCH_ERROR;
2045     }
2046
2047   cp = gfc_get_code ();
2048   cp->op = EXEC_TRANSFER;
2049   cp->expr = expr;
2050
2051   *cpp = cp;
2052   return MATCH_YES;
2053 }
2054
2055
2056 /* Match an I/O list, building gfc_code structures as we go.  */
2057
2058 static match
2059 match_io_list (io_kind k, gfc_code ** head_p)
2060 {
2061   gfc_code *head, *tail, *new;
2062   match m;
2063
2064   *head_p = head = tail = NULL;
2065   if (gfc_match_eos () == MATCH_YES)
2066     return MATCH_YES;
2067
2068   for (;;)
2069     {
2070       m = match_io_element (k, &new);
2071       if (m == MATCH_ERROR)
2072         goto cleanup;
2073       if (m == MATCH_NO)
2074         goto syntax;
2075
2076       tail = gfc_append_code (tail, new);
2077       if (head == NULL)
2078         head = new;
2079
2080       if (gfc_match_eos () == MATCH_YES)
2081         break;
2082       if (gfc_match_char (',') != MATCH_YES)
2083         goto syntax;
2084     }
2085
2086   *head_p = head;
2087   return MATCH_YES;
2088
2089 syntax:
2090   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2091
2092 cleanup:
2093   gfc_free_statements (head);
2094   return MATCH_ERROR;
2095 }
2096
2097
2098 /* Attach the data transfer end node.  */
2099
2100 static void
2101 terminate_io (gfc_code * io_code)
2102 {
2103   gfc_code *c;
2104
2105   if (io_code == NULL)
2106     io_code = &new_st;
2107
2108   c = gfc_get_code ();
2109   c->op = EXEC_DT_END;
2110
2111   /* Point to structure that is already there */
2112   c->ext.dt = new_st.ext.dt;
2113   gfc_append_code (io_code, c);
2114 }
2115
2116
2117 /* Match a READ, WRITE or PRINT statement.  */
2118
2119 static match
2120 match_io (io_kind k)
2121 {
2122   char name[GFC_MAX_SYMBOL_LEN + 1];
2123   gfc_code *io_code;
2124   gfc_symbol *sym;
2125   gfc_expr *expr;
2126   int comma_flag, c;
2127   locus where;
2128   gfc_dt *dt;
2129   match m;
2130
2131   comma_flag = 0;
2132   current_dt = dt = gfc_getmem (sizeof (gfc_dt));
2133
2134   if (gfc_match_char ('(') == MATCH_NO)
2135     {
2136       if (k == M_WRITE)
2137         goto syntax;
2138       else if (k == M_PRINT
2139                && (gfc_current_form == FORM_FIXED
2140                    || gfc_peek_char () == ' '))
2141         {
2142           /* Treat the non-standard case of PRINT namelist.  */
2143           where = gfc_current_locus;
2144           if ((gfc_match_name (name) == MATCH_YES)
2145               && !gfc_find_symbol (name, NULL, 1, &sym)
2146               && sym->attr.flavor == FL_NAMELIST)
2147             {
2148               if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
2149                                   "%C is an extension") == FAILURE)
2150                 {
2151                   m = MATCH_ERROR;
2152                   goto cleanup;
2153                 }
2154               if (gfc_match_eos () == MATCH_NO)
2155                 {
2156                   gfc_error ("Namelist followed by I/O list at %C");
2157                   m = MATCH_ERROR;
2158                   goto cleanup;
2159                 }
2160
2161               dt->io_unit = default_unit (k);
2162               dt->namelist = sym;
2163               goto get_io_list;
2164             }
2165           else
2166             gfc_current_locus = where;
2167         }
2168
2169       if (gfc_current_form == FORM_FREE)
2170        {
2171          c = gfc_peek_char();
2172          if (c != ' ' && c != '*' && c != '\'' && c != '"')
2173            {
2174              m = MATCH_NO;
2175              goto cleanup;
2176            }
2177        }
2178
2179       m = match_dt_format (dt);
2180       if (m == MATCH_ERROR)
2181         goto cleanup;
2182       if (m == MATCH_NO)
2183         goto syntax;
2184
2185       comma_flag = 1;
2186       dt->io_unit = default_unit (k);
2187       goto get_io_list;
2188     }
2189
2190   /* Match a control list */
2191   if (match_dt_element (k, dt) == MATCH_YES)
2192     goto next;
2193   if (match_dt_unit (k, dt) != MATCH_YES)
2194     goto loop;
2195
2196   if (gfc_match_char (')') == MATCH_YES)
2197     goto get_io_list;
2198   if (gfc_match_char (',') != MATCH_YES)
2199     goto syntax;
2200
2201   m = match_dt_element (k, dt);
2202   if (m == MATCH_YES)
2203     goto next;
2204   if (m == MATCH_ERROR)
2205     goto cleanup;
2206
2207   m = match_dt_format (dt);
2208   if (m == MATCH_YES)
2209     goto next;
2210   if (m == MATCH_ERROR)
2211     goto cleanup;
2212
2213   where = gfc_current_locus;
2214
2215   if (gfc_match_name (name) == MATCH_YES
2216       && !gfc_find_symbol (name, NULL, 1, &sym)
2217       && sym->attr.flavor == FL_NAMELIST)
2218     {
2219       dt->namelist = sym;
2220       if (k == M_READ && check_namelist (sym))
2221         {
2222           m = MATCH_ERROR;
2223           goto cleanup;
2224         }
2225       goto next;
2226     }
2227
2228   gfc_current_locus = where;
2229
2230   goto loop;                    /* No matches, try regular elements */
2231
2232 next:
2233   if (gfc_match_char (')') == MATCH_YES)
2234     goto get_io_list;
2235   if (gfc_match_char (',') != MATCH_YES)
2236     goto syntax;
2237
2238 loop:
2239   for (;;)
2240     {
2241       m = match_dt_element (k, dt);
2242       if (m == MATCH_NO)
2243         goto syntax;
2244       if (m == MATCH_ERROR)
2245         goto cleanup;
2246
2247       if (gfc_match_char (')') == MATCH_YES)
2248         break;
2249       if (gfc_match_char (',') != MATCH_YES)
2250         goto syntax;
2251     }
2252
2253 get_io_list:
2254   /* Optional leading comma (non-standard).  */
2255   if (!comma_flag
2256       && gfc_match_char (',') == MATCH_YES
2257       && k == M_WRITE
2258       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before output "
2259                          "item list at %C is an extension") == FAILURE)
2260     return MATCH_ERROR;
2261
2262   io_code = NULL;
2263   if (gfc_match_eos () != MATCH_YES)
2264     {
2265       if (comma_flag && gfc_match_char (',') != MATCH_YES)
2266         {
2267           gfc_error ("Expected comma in I/O list at %C");
2268           m = MATCH_ERROR;
2269           goto cleanup;
2270         }
2271
2272       m = match_io_list (k, &io_code);
2273       if (m == MATCH_ERROR)
2274         goto cleanup;
2275       if (m == MATCH_NO)
2276         goto syntax;
2277     }
2278
2279   /* A full IO statement has been matched.  */
2280   if (dt->io_unit->expr_type == EXPR_VARIABLE
2281       && k == M_WRITE
2282       && dt->io_unit->ts.type == BT_CHARACTER
2283       && dt->io_unit->symtree->n.sym->attr.intent == INTENT_IN)
2284     {
2285       gfc_error ("Internal file '%s' at %L is INTENT(IN)",
2286                  dt->io_unit->symtree->n.sym->name, &dt->io_unit->where);
2287       m = MATCH_ERROR;
2288       goto cleanup;
2289     }
2290
2291   expr = dt->format_expr;
2292
2293   if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
2294     check_format_string (expr);
2295
2296   if (gfc_pure (NULL)
2297       && (k == M_READ || k == M_WRITE)
2298       && dt->io_unit->ts.type != BT_CHARACTER)
2299     {
2300       gfc_error
2301         ("io-unit in %s statement at %C must be an internal file in a "
2302          "PURE procedure", io_kind_name (k));
2303       m = MATCH_ERROR;
2304       goto cleanup;
2305     }
2306
2307   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
2308   new_st.ext.dt = dt;
2309   new_st.next = io_code;
2310
2311   terminate_io (io_code);
2312
2313   return MATCH_YES;
2314
2315 syntax:
2316   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2317   m = MATCH_ERROR;
2318
2319 cleanup:
2320   gfc_free_dt (dt);
2321   return m;
2322 }
2323
2324
2325 match
2326 gfc_match_read (void)
2327 {
2328   return match_io (M_READ);
2329 }
2330
2331 match
2332 gfc_match_write (void)
2333 {
2334   return match_io (M_WRITE);
2335 }
2336
2337 match
2338 gfc_match_print (void)
2339 {
2340   match m;
2341
2342   m = match_io (M_PRINT);
2343   if (m != MATCH_YES)
2344     return m;
2345
2346   if (gfc_pure (NULL))
2347     {
2348       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
2349       return MATCH_ERROR;
2350     }
2351
2352   return MATCH_YES;
2353 }
2354
2355
2356 /* Free a gfc_inquire structure.  */
2357
2358 void
2359 gfc_free_inquire (gfc_inquire * inquire)
2360 {
2361
2362   if (inquire == NULL)
2363     return;
2364
2365   gfc_free_expr (inquire->unit);
2366   gfc_free_expr (inquire->file);
2367   gfc_free_expr (inquire->iostat);
2368   gfc_free_expr (inquire->exist);
2369   gfc_free_expr (inquire->opened);
2370   gfc_free_expr (inquire->number);
2371   gfc_free_expr (inquire->named);
2372   gfc_free_expr (inquire->name);
2373   gfc_free_expr (inquire->access);
2374   gfc_free_expr (inquire->sequential);
2375   gfc_free_expr (inquire->direct);
2376   gfc_free_expr (inquire->form);
2377   gfc_free_expr (inquire->formatted);
2378   gfc_free_expr (inquire->unformatted);
2379   gfc_free_expr (inquire->recl);
2380   gfc_free_expr (inquire->nextrec);
2381   gfc_free_expr (inquire->blank);
2382   gfc_free_expr (inquire->position);
2383   gfc_free_expr (inquire->action);
2384   gfc_free_expr (inquire->read);
2385   gfc_free_expr (inquire->write);
2386   gfc_free_expr (inquire->readwrite);
2387   gfc_free_expr (inquire->delim);
2388   gfc_free_expr (inquire->pad);
2389   gfc_free_expr (inquire->iolength);
2390
2391   gfc_free (inquire);
2392 }
2393
2394
2395 /* Match an element of an INQUIRE statement.  */
2396
2397 #define RETM   if (m != MATCH_NO) return m;
2398
2399 static match
2400 match_inquire_element (gfc_inquire * inquire)
2401 {
2402   match m;
2403
2404   m = match_etag (&tag_unit, &inquire->unit);
2405   RETM m = match_etag (&tag_file, &inquire->file);
2406   RETM m = match_ltag (&tag_err, &inquire->err);
2407   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
2408   RETM m = match_vtag (&tag_exist, &inquire->exist);
2409   RETM m = match_vtag (&tag_opened, &inquire->opened);
2410   RETM m = match_vtag (&tag_named, &inquire->named);
2411   RETM m = match_vtag (&tag_name, &inquire->name);
2412   RETM m = match_out_tag (&tag_number, &inquire->number);
2413   RETM m = match_vtag (&tag_s_access, &inquire->access);
2414   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
2415   RETM m = match_vtag (&tag_direct, &inquire->direct);
2416   RETM m = match_vtag (&tag_s_form, &inquire->form);
2417   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
2418   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
2419   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
2420   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
2421   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
2422   RETM m = match_vtag (&tag_s_position, &inquire->position);
2423   RETM m = match_vtag (&tag_s_action, &inquire->action);
2424   RETM m = match_vtag (&tag_read, &inquire->read);
2425   RETM m = match_vtag (&tag_write, &inquire->write);
2426   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
2427   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
2428   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
2429   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
2430   RETM return MATCH_NO;
2431 }
2432
2433 #undef RETM
2434
2435
2436 match
2437 gfc_match_inquire (void)
2438 {
2439   gfc_inquire *inquire;
2440   gfc_code *code;
2441   match m;
2442   locus loc;
2443
2444   m = gfc_match_char ('(');
2445   if (m == MATCH_NO)
2446     return m;
2447
2448   inquire = gfc_getmem (sizeof (gfc_inquire));
2449
2450   loc = gfc_current_locus;
2451
2452   m = match_inquire_element (inquire);
2453   if (m == MATCH_ERROR)
2454     goto cleanup;
2455   if (m == MATCH_NO)
2456     {
2457       m = gfc_match_expr (&inquire->unit);
2458       if (m == MATCH_ERROR)
2459         goto cleanup;
2460       if (m == MATCH_NO)
2461         goto syntax;
2462     }
2463
2464   /* See if we have the IOLENGTH form of the inquire statement.  */
2465   if (inquire->iolength != NULL)
2466     {
2467       if (gfc_match_char (')') != MATCH_YES)
2468         goto syntax;
2469
2470       m = match_io_list (M_INQUIRE, &code);
2471       if (m == MATCH_ERROR)
2472         goto cleanup;
2473       if (m == MATCH_NO)
2474         goto syntax;
2475
2476       terminate_io (code);
2477
2478       new_st.op = EXEC_IOLENGTH;
2479       new_st.expr = inquire->iolength;
2480       new_st.ext.inquire = inquire;
2481
2482       if (gfc_pure (NULL))
2483         {
2484           gfc_free_statements (code);
2485           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2486           return MATCH_ERROR;
2487         }
2488
2489       new_st.next = code;
2490       return MATCH_YES;
2491     }
2492
2493   /* At this point, we have the non-IOLENGTH inquire statement.  */
2494   for (;;)
2495     {
2496       if (gfc_match_char (')') == MATCH_YES)
2497         break;
2498       if (gfc_match_char (',') != MATCH_YES)
2499         goto syntax;
2500
2501       m = match_inquire_element (inquire);
2502       if (m == MATCH_ERROR)
2503         goto cleanup;
2504       if (m == MATCH_NO)
2505         goto syntax;
2506
2507       if (inquire->iolength != NULL)
2508         {
2509           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
2510           goto cleanup;
2511         }
2512     }
2513
2514   if (gfc_match_eos () != MATCH_YES)
2515     goto syntax;
2516
2517   if (inquire->unit != NULL && inquire->file != NULL)
2518     {
2519       gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
2520                  " UNIT specifiers", &loc);
2521       goto cleanup;
2522     }
2523
2524   if (inquire->unit == NULL && inquire->file == NULL)
2525     {
2526       gfc_error ("INQUIRE statement at %L requires either FILE or"
2527                      " UNIT specifier", &loc);
2528       goto cleanup;
2529     }
2530
2531   if (gfc_pure (NULL))
2532     {
2533       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2534       goto cleanup;
2535     }
2536
2537   new_st.op = EXEC_INQUIRE;
2538   new_st.ext.inquire = inquire;
2539   return MATCH_YES;
2540
2541 syntax:
2542   gfc_syntax_error (ST_INQUIRE);
2543
2544 cleanup:
2545   gfc_free_inquire (inquire);
2546   return MATCH_ERROR;
2547 }
2548
2549
2550 /* Resolve everything in a gfc_inquire structure.  */
2551
2552 try
2553 gfc_resolve_inquire (gfc_inquire * inquire)
2554 {
2555
2556   RESOLVE_TAG (&tag_unit, inquire->unit);
2557   RESOLVE_TAG (&tag_file, inquire->file);
2558   RESOLVE_TAG (&tag_iostat, inquire->iostat);
2559   RESOLVE_TAG (&tag_exist, inquire->exist);
2560   RESOLVE_TAG (&tag_opened, inquire->opened);
2561   RESOLVE_TAG (&tag_number, inquire->number);
2562   RESOLVE_TAG (&tag_named, inquire->named);
2563   RESOLVE_TAG (&tag_name, inquire->name);
2564   RESOLVE_TAG (&tag_s_access, inquire->access);
2565   RESOLVE_TAG (&tag_sequential, inquire->sequential);
2566   RESOLVE_TAG (&tag_direct, inquire->direct);
2567   RESOLVE_TAG (&tag_s_form, inquire->form);
2568   RESOLVE_TAG (&tag_formatted, inquire->formatted);
2569   RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
2570   RESOLVE_TAG (&tag_s_recl, inquire->recl);
2571   RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
2572   RESOLVE_TAG (&tag_s_blank, inquire->blank);
2573   RESOLVE_TAG (&tag_s_position, inquire->position);
2574   RESOLVE_TAG (&tag_s_action, inquire->action);
2575   RESOLVE_TAG (&tag_read, inquire->read);
2576   RESOLVE_TAG (&tag_write, inquire->write);
2577   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
2578   RESOLVE_TAG (&tag_s_delim, inquire->delim);
2579   RESOLVE_TAG (&tag_s_pad, inquire->pad);
2580   RESOLVE_TAG (&tag_iolength, inquire->iolength);
2581
2582   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
2583     return FAILURE;
2584
2585   return SUCCESS;
2586 }