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