gcc/fortran/io.c

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