gcc/fortran/io.c

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