gcc/fortran/io.c

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