gcc/fortran/io.c

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