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