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   if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
 923     return SUCCESS;
 924
 925   mode = MODE_STRING;
 926   format_string = e->value.character.string;
 927   return check_format (is_input);
 928 }
 929
 930
 931 /************ Fortran 95 I/O statement matchers *************/
 932
 933 /* Match a FORMAT statement.  This amounts to actually parsing the
 934    format descriptors in order to correctly locate the end of the
 935    format string.  */
 936
 937 match
 938 gfc_match_format (void)
 939 {
 940   gfc_expr *e;
 941   locus start;
 942
 943   if (gfc_current_ns->proc_name
 944       && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
 945     {
 946       gfc_error ("Format statement in module main block at %C");
 947       return MATCH_ERROR;
 948     }
 949
 950   if (gfc_statement_label == NULL)
 951     {
 952       gfc_error ("Missing format label at %C");
 953       return MATCH_ERROR;
 954     }
 955   gfc_gobble_whitespace ();
 956
 957   mode = MODE_FORMAT;
 958   format_length = 0;
 959
 960   start = gfc_current_locus;
 961
 962   if (check_format (false) == FAILURE)
 963     return MATCH_ERROR;
 964
 965   if (gfc_match_eos () != MATCH_YES)
 966     {
 967       gfc_syntax_error (ST_FORMAT);
 968       return MATCH_ERROR;
 969     }
 970
 971   /* The label doesn't get created until after the statement is done
 972      being matched, so we have to leave the string for later.  */
 973
 974   gfc_current_locus = start;    /* Back to the beginning */
 975
 976   new_st.loc = start;
 977   new_st.op = EXEC_NOP;
 978
 979   e = gfc_get_expr();
 980   e->expr_type = EXPR_CONSTANT;
 981   e->ts.type = BT_CHARACTER;
 982   e->ts.kind = gfc_default_character_kind;
 983   e->where = start;
 984   e->value.character.string = format_string = gfc_getmem (format_length + 1);
 985   e->value.character.length = format_length;
 986   gfc_statement_label->format = e;
 987
 988   mode = MODE_COPY;
 989   check_format (false);         /* Guaranteed to succeed */
 990   gfc_match_eos ();             /* Guaranteed to succeed */
 991
 992   return MATCH_YES;
 993 }
 994
 995
 996 /* Match an expression I/O tag of some sort.  */
 997
 998 static match
 999 match_etag (const io_tag *tag, gfc_expr **v)
1000 {
1001   gfc_expr *result;
1002   match m;
1003
1004   m = gfc_match (tag->spec, &result);
1005   if (m != MATCH_YES)
1006     return m;
1007
1008   if (*v != NULL)
1009     {
1010       gfc_error ("Duplicate %s specification at %C", tag->name);
1011       gfc_free_expr (result);
1012       return MATCH_ERROR;
1013     }
1014
1015   *v = result;
1016   return MATCH_YES;
1017 }
1018
1019
1020 /* Match a variable I/O tag of some sort.  */
1021
1022 static match
1023 match_vtag (const io_tag *tag, gfc_expr **v)
1024 {
1025   gfc_expr *result;
1026   match m;
1027
1028   m = gfc_match (tag->spec, &result);
1029   if (m != MATCH_YES)
1030     return m;
1031
1032   if (*v != NULL)
1033     {
1034       gfc_error ("Duplicate %s specification at %C", tag->name);
1035       gfc_free_expr (result);
1036       return MATCH_ERROR;
1037     }
1038
1039   if (result->symtree->n.sym->attr.intent == INTENT_IN)
1040     {
1041       gfc_error ("Variable tag cannot be INTENT(IN) at %C");
1042       gfc_free_expr (result);
1043       return MATCH_ERROR;
1044     }
1045
1046   if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1047     {
1048       gfc_error ("Variable tag cannot be assigned in PURE procedure at %C");
1049       gfc_free_expr (result);
1050       return MATCH_ERROR;
1051     }
1052
1053   *v = result;
1054   return MATCH_YES;
1055 }
1056
1057
1058 /* Match I/O tags that cause variables to become redefined.  */
1059
1060 static match
1061 match_out_tag(const io_tag *tag, gfc_expr **result)
1062 {
1063   match m;
1064
1065   m = match_vtag(tag, result);
1066   if (m == MATCH_YES)
1067     gfc_check_do_variable((*result)->symtree);
1068
1069   return m;
1070 }
1071
1072
1073 /* Match a label I/O tag.  */
1074
1075 static match
1076 match_ltag (const io_tag *tag, gfc_st_label ** label)
1077 {
1078   match m;
1079   gfc_st_label *old;
1080
1081   old = *label;
1082   m = gfc_match (tag->spec, label);
1083   if (m == MATCH_YES && old != 0)
1084     {
1085       gfc_error ("Duplicate %s label specification at %C", tag->name);
1086       return MATCH_ERROR;
1087     }
1088
1089   if (m == MATCH_YES
1090       && gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1091     return MATCH_ERROR;
1092
1093   return m;
1094 }
1095
1096
1097 /* Resolution of the FORMAT tag, to be called from resolve_tag.  */
1098
1099 static try
1100 resolve_tag_format (const gfc_expr *e)
1101 {
1102   if (e->expr_type == EXPR_CONSTANT
1103       && (e->ts.type != BT_CHARACTER
1104           || e->ts.kind != gfc_default_character_kind))
1105     {
1106       gfc_error ("Constant expression in FORMAT tag at %L must be "
1107                  "of type default CHARACTER", &e->where);
1108       return FAILURE;
1109     }
1110
1111   /* If e's rank is zero and e is not an element of an array, it should be
1112      of integer or character type.  The integer variable should be
1113      ASSIGNED.  */
1114   if (e->symtree == NULL || e->symtree->n.sym->as == NULL
1115       || e->symtree->n.sym->as->rank == 0)
1116     {
1117       if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1118         {
1119           gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1120                      &e->where);
1121           return FAILURE;
1122         }
1123       else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1124         {
1125           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1126                               "variable in FORMAT tag at %L", &e->where)
1127               == FAILURE)
1128             return FAILURE;
1129           if (e->symtree->n.sym->attr.assign != 1)
1130             {
1131               gfc_error ("Variable '%s' at %L has not been assigned a "
1132                          "format label", e->symtree->n.sym->name, &e->where);
1133               return FAILURE;
1134             }
1135         }
1136       else if (e->ts.type == BT_INTEGER)
1137         {
1138           gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1139                      "variable", gfc_basic_typename (e->ts.type), &e->where);
1140           return FAILURE;
1141         }
1142
1143       return SUCCESS;
1144     }
1145
1146   /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU
1147      and other type under GFC_STD_LEGACY. It may be assigned an Hollerith
1148      constant.  */
1149   if (e->ts.type == BT_CHARACTER)
1150     {
1151       if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
1152                           "in FORMAT tag at %L", &e->where) == FAILURE)
1153         return FAILURE;
1154     }
1155   else
1156     {
1157       if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1158                           "in FORMAT tag at %L", &e->where) == FAILURE)
1159         return FAILURE;
1160     }
1161
1162   return SUCCESS;
1163 }
1164
1165
1166 /* Do expression resolution and type-checking on an expression tag.  */
1167
1168 static try
1169 resolve_tag (const io_tag *tag, gfc_expr *e)
1170 {
1171   if (e == NULL)
1172     return SUCCESS;
1173
1174   if (gfc_resolve_expr (e) == FAILURE)
1175     return FAILURE;
1176
1177   if (tag == &tag_format)
1178     return resolve_tag_format (e);
1179
1180   if (e->ts.type != tag->type)
1181     {
1182       gfc_error ("%s tag at %L must be of type %s", tag->name,
1183                  &e->where, gfc_basic_typename (tag->type));
1184       return FAILURE;
1185     }
1186
1187   if (e->rank != 0)
1188     {
1189       gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1190       return FAILURE;
1191     }
1192
1193   if (tag == &tag_iomsg)
1194     {
1195       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1196                           &e->where) == FAILURE)
1197         return FAILURE;
1198     }
1199
1200   if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1201       && e->ts.kind != gfc_default_integer_kind)
1202     {
1203       if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1204                           "INTEGER in %s tag at %L", tag->name, &e->where)
1205           == FAILURE)
1206         return FAILURE;
1207     }
1208
1209   if (tag == &tag_convert)
1210     {
1211       if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1212                           &e->where) == FAILURE)
1213         return FAILURE;
1214     }
1215
1216   return SUCCESS;
1217 }
1218
1219
1220 /* Match a single tag of an OPEN statement.  */
1221
1222 static match
1223 match_open_element (gfc_open *open)
1224 {
1225   match m;
1226
1227   m = match_etag (&tag_unit, &open->unit);
1228   if (m != MATCH_NO)
1229     return m;
1230   m = match_out_tag (&tag_iomsg, &open->iomsg);
1231   if (m != MATCH_NO)
1232     return m;
1233   m = match_out_tag (&tag_iostat, &open->iostat);
1234   if (m != MATCH_NO)
1235     return m;
1236   m = match_etag (&tag_file, &open->file);
1237   if (m != MATCH_NO)
1238     return m;
1239   m = match_etag (&tag_status, &open->status);
1240   if (m != MATCH_NO)
1241     return m;
1242   m = match_etag (&tag_e_access, &open->access);
1243   if (m != MATCH_NO)
1244     return m;
1245   m = match_etag (&tag_e_form, &open->form);
1246   if (m != MATCH_NO)
1247     return m;
1248   m = match_etag (&tag_e_recl, &open->recl);
1249   if (m != MATCH_NO)
1250     return m;
1251   m = match_etag (&tag_e_blank, &open->blank);
1252   if (m != MATCH_NO)
1253     return m;
1254   m = match_etag (&tag_e_position, &open->position);
1255   if (m != MATCH_NO)
1256     return m;
1257   m = match_etag (&tag_e_action, &open->action);
1258   if (m != MATCH_NO)
1259     return m;
1260   m = match_etag (&tag_e_delim, &open->delim);
1261   if (m != MATCH_NO)
1262     return m;
1263   m = match_etag (&tag_e_pad, &open->pad);
1264   if (m != MATCH_NO)
1265     return m;
1266   m = match_ltag (&tag_err, &open->err);
1267   if (m != MATCH_NO)
1268     return m;
1269   m = match_etag (&tag_convert, &open->convert);
1270   if (m != MATCH_NO)
1271     return m;
1272
1273   return MATCH_NO;
1274 }
1275
1276
1277 /* Free the gfc_open structure and all the expressions it contains.  */
1278
1279 void
1280 gfc_free_open (gfc_open *open)
1281 {
1282   if (open == NULL)
1283     return;
1284
1285   gfc_free_expr (open->unit);
1286   gfc_free_expr (open->iomsg);
1287   gfc_free_expr (open->iostat);
1288   gfc_free_expr (open->file);
1289   gfc_free_expr (open->status);
1290   gfc_free_expr (open->access);
1291   gfc_free_expr (open->form);
1292   gfc_free_expr (open->recl);
1293   gfc_free_expr (open->blank);
1294   gfc_free_expr (open->position);
1295   gfc_free_expr (open->action);
1296   gfc_free_expr (open->delim);
1297   gfc_free_expr (open->pad);
1298   gfc_free_expr (open->convert);
1299   gfc_free (open);
1300 }
1301
1302
1303 /* Resolve everything in a gfc_open structure.  */
1304
1305 try
1306 gfc_resolve_open (gfc_open *open)
1307 {
1308
1309   RESOLVE_TAG (&tag_unit, open->unit);
1310   RESOLVE_TAG (&tag_iomsg, open->iomsg);
1311   RESOLVE_TAG (&tag_iostat, open->iostat);
1312   RESOLVE_TAG (&tag_file, open->file);
1313   RESOLVE_TAG (&tag_status, open->status);
1314   RESOLVE_TAG (&tag_e_access, open->access);
1315   RESOLVE_TAG (&tag_e_form, open->form);
1316   RESOLVE_TAG (&tag_e_recl, open->recl);
1317   RESOLVE_TAG (&tag_e_blank, open->blank);
1318   RESOLVE_TAG (&tag_e_position, open->position);
1319   RESOLVE_TAG (&tag_e_action, open->action);
1320   RESOLVE_TAG (&tag_e_delim, open->delim);
1321   RESOLVE_TAG (&tag_e_pad, open->pad);
1322   RESOLVE_TAG (&tag_convert, open->convert);
1323
1324   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1325     return FAILURE;
1326
1327   return SUCCESS;
1328 }
1329
1330
1331 /* Check if a given value for a SPECIFIER is either in the list of values
1332    allowed in F95 or F2003, issuing an error message and returning a zero
1333    value if it is not allowed.  */
1334
1335 static int
1336 compare_to_allowed_values (const char *specifier, const char *allowed[],
1337                            const char *allowed_f2003[],
1338                            const char *allowed_gnu[], char *value,
1339                            const char *statement, bool warn)
1340 {
1341   int i;
1342   unsigned int len;
1343
1344   len = strlen (value);
1345   if (len > 0)
1346   {
1347     for (len--; len > 0; len--)
1348       if (value[len] != ' ')
1349         break;
1350     len++;
1351   }
1352
1353   for (i = 0; allowed[i]; i++)
1354     if (len == strlen (allowed[i])
1355         && strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1356       return 1;
1357
1358   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1359     if (len == strlen (allowed_f2003[i])
1360         && strncasecmp (value, allowed_f2003[i], strlen (allowed_f2003[i]))
1361            == 0)
1362       {
1363         notification n = gfc_notification_std (GFC_STD_F2003);
1364
1365         if (n == WARNING || (warn && n == ERROR))
1366           {
1367             gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1368                          "has value '%s'", specifier, statement,
1369                          allowed_f2003[i]);
1370             return 1;
1371           }
1372         else
1373           if (n == ERROR)
1374             {
1375               gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1376                               "%s statement at %C has value '%s'", specifier,
1377                               statement, allowed_f2003[i]);
1378               return 0;
1379             }
1380
1381         /* n == SILENT */
1382         return 1;
1383       }
1384
1385   for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1386     if (len == strlen (allowed_gnu[i])
1387         && strncasecmp (value, allowed_gnu[i], strlen (allowed_gnu[i])) == 0)
1388       {
1389         notification n = gfc_notification_std (GFC_STD_GNU);
1390
1391         if (n == WARNING || (warn && n == ERROR))
1392           {
1393             gfc_warning ("Extension: %s specifier in %s statement at %C "
1394                          "has value '%s'", specifier, statement,
1395                          allowed_gnu[i]);
1396             return 1;
1397           }
1398         else
1399           if (n == ERROR)
1400             {
1401               gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1402                               "%s statement at %C has value '%s'", specifier,
1403                               statement, allowed_gnu[i]);
1404               return 0;
1405             }
1406
1407         /* n == SILENT */
1408         return 1;
1409       }
1410
1411   if (warn)
1412     {
1413       gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1414                    specifier, statement, value);
1415       return 1;
1416     }
1417   else
1418     {
1419       gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1420                  specifier, statement, value);
1421       return 0;
1422     }
1423 }
1424
1425
1426 /* Match an OPEN statement.  */
1427
1428 match
1429 gfc_match_open (void)
1430 {
1431   gfc_open *open;
1432   match m;
1433   bool warn;
1434
1435   m = gfc_match_char ('(');
1436   if (m == MATCH_NO)
1437     return m;
1438
1439   open = gfc_getmem (sizeof (gfc_open));
1440
1441   m = match_open_element (open);
1442
1443   if (m == MATCH_ERROR)
1444     goto cleanup;
1445   if (m == MATCH_NO)
1446     {
1447       m = gfc_match_expr (&open->unit);
1448       if (m == MATCH_NO)
1449         goto syntax;
1450       if (m == MATCH_ERROR)
1451         goto cleanup;
1452     }
1453
1454   for (;;)
1455     {
1456       if (gfc_match_char (')') == MATCH_YES)
1457         break;
1458       if (gfc_match_char (',') != MATCH_YES)
1459         goto syntax;
1460
1461       m = match_open_element (open);
1462       if (m == MATCH_ERROR)
1463         goto cleanup;
1464       if (m == MATCH_NO)
1465         goto syntax;
1466     }
1467
1468   if (gfc_match_eos () == MATCH_NO)
1469     goto syntax;
1470
1471   if (gfc_pure (NULL))
1472     {
1473       gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1474       goto cleanup;
1475     }
1476
1477   warn = (open->err || open->iostat) ? true : false;
1478   /* Checks on the ACCESS specifier.  */
1479   if (open->access && open->access->expr_type == EXPR_CONSTANT)
1480     {
1481       static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1482       static const char *access_f2003[] = { "STREAM", NULL };
1483       static const char *access_gnu[] = { "APPEND", NULL };
1484
1485       if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1486                                       access_gnu,
1487                                       open->access->value.character.string,
1488                                       "OPEN", warn))
1489         goto cleanup;
1490     }
1491
1492   /* Checks on the ACTION specifier.  */
1493   if (open->action && open->action->expr_type == EXPR_CONSTANT)
1494     {
1495       static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1496
1497       if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1498                                       open->action->value.character.string,
1499                                       "OPEN", warn))
1500         goto cleanup;
1501     }
1502
1503   /* Checks on the ASYNCHRONOUS specifier.  */
1504   /* TODO: code is ready, just needs uncommenting when async I/O support
1505      is added ;-)
1506   if (open->asynchronous && open->asynchronous->expr_type == EXPR_CONSTANT)
1507     {
1508       static const char * asynchronous[] = { "YES", "NO", NULL };
1509
1510       if (!compare_to_allowed_values
1511                 ("action", asynchronous, NULL, NULL,
1512                  open->asynchronous->value.character.string, "OPEN", warn))
1513         goto cleanup;
1514     }*/
1515
1516   /* Checks on the BLANK specifier.  */
1517   if (open->blank && open->blank->expr_type == EXPR_CONSTANT)
1518     {
1519       static const char *blank[] = { "ZERO", "NULL", NULL };
1520
1521       if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1522                                       open->blank->value.character.string,
1523                                       "OPEN", warn))
1524         goto cleanup;
1525     }
1526
1527   /* Checks on the DECIMAL specifier.  */
1528   /* TODO: uncomment this code when DECIMAL support is added
1529   if (open->decimal && open->decimal->expr_type == EXPR_CONSTANT)
1530     {
1531       static const char * decimal[] = { "COMMA", "POINT", NULL };
1532
1533       if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1534                                       open->decimal->value.character.string,
1535                                       "OPEN", warn))
1536         goto cleanup;
1537     } */
1538
1539   /* Checks on the DELIM specifier.  */
1540   if (open->delim && open->delim->expr_type == EXPR_CONSTANT)
1541     {
1542       static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1543
1544       if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1545                                       open->delim->value.character.string,
1546                                       "OPEN", warn))
1547         goto cleanup;
1548     }
1549
1550   /* Checks on the ENCODING specifier.  */
1551   /* TODO: uncomment this code when ENCODING support is added
1552   if (open->encoding && open->encoding->expr_type == EXPR_CONSTANT)
1553     {
1554       static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
1555
1556       if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1557                                       open->encoding->value.character.string,
1558                                       "OPEN", warn))
1559         goto cleanup;
1560     } */
1561
1562   /* Checks on the FORM specifier.  */
1563   if (open->form && open->form->expr_type == EXPR_CONSTANT)
1564     {
1565       static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1566
1567       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1568                                       open->form->value.character.string,
1569                                       "OPEN", warn))
1570         goto cleanup;
1571     }
1572
1573   /* Checks on the PAD specifier.  */
1574   if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1575     {
1576       static const char *pad[] = { "YES", "NO", NULL };
1577
1578       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1579                                       open->pad->value.character.string,
1580                                       "OPEN", warn))
1581         goto cleanup;
1582     }
1583
1584   /* Checks on the POSITION specifier.  */
1585   if (open->position && open->position->expr_type == EXPR_CONSTANT)
1586     {
1587       static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
1588
1589       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
1590                                       open->position->value.character.string,
1591                                       "OPEN", warn))
1592         goto cleanup;
1593     }
1594
1595   /* Checks on the ROUND specifier.  */
1596   /* TODO: uncomment this code when ROUND support is added
1597   if (open->round && open->round->expr_type == EXPR_CONSTANT)
1598     {
1599       static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
1600                                       "COMPATIBLE", "PROCESSOR_DEFINED", NULL };
1601
1602       if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
1603                                       open->round->value.character.string,
1604                                       "OPEN", warn))
1605         goto cleanup;
1606     } */
1607
1608   /* Checks on the SIGN specifier.  */
1609   /* TODO: uncomment this code when SIGN support is added
1610   if (open->sign && open->sign->expr_type == EXPR_CONSTANT)
1611     {
1612       static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
1613                                      NULL };
1614
1615       if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
1616                                       open->sign->value.character.string,
1617                                       "OPEN", warn))
1618         goto cleanup;
1619     } */
1620
1621 #define warn_or_error(...) \
1622 { \
1623   if (warn) \
1624     gfc_warning (__VA_ARGS__); \
1625   else \
1626     { \
1627       gfc_error (__VA_ARGS__); \
1628       goto cleanup; \
1629     } \
1630 }
1631
1632   /* Checks on the RECL specifier.  */
1633   if (open->recl && open->recl->expr_type == EXPR_CONSTANT
1634       && open->recl->ts.type == BT_INTEGER
1635       && mpz_sgn (open->recl->value.integer) != 1)
1636     {
1637       warn_or_error ("RECL in OPEN statement at %C must be positive");
1638     }
1639
1640   /* Checks on the STATUS specifier.  */
1641   if (open->status && open->status->expr_type == EXPR_CONSTANT)
1642     {
1643       static const char *status[] = { "OLD", "NEW", "SCRATCH",
1644         "REPLACE", "UNKNOWN", NULL };
1645
1646       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
1647                                       open->status->value.character.string,
1648                                       "OPEN", warn))
1649         goto cleanup;
1650
1651       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
1652          the FILE= specifier shall appear.  */
1653       if (open->file == NULL
1654           && (strncasecmp (open->status->value.character.string, "replace", 7)
1655               == 0
1656              || strncasecmp (open->status->value.character.string, "new", 3)
1657                 == 0))
1658         {
1659           warn_or_error ("The STATUS specified in OPEN statement at %C is "
1660                          "'%s' and no FILE specifier is present",
1661                          open->status->value.character.string);
1662         }
1663
1664       /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
1665          the FILE= specifier shall not appear.  */
1666       if (strncasecmp (open->status->value.character.string, "scratch", 7)
1667           == 0 && open->file)
1668         {
1669           warn_or_error ("The STATUS specified in OPEN statement at %C "
1670                          "cannot have the value SCRATCH if a FILE specifier "
1671                          "is present");
1672         }
1673     }
1674
1675   /* Things that are not allowed for unformatted I/O.  */
1676   if (open->form && open->form->expr_type == EXPR_CONSTANT
1677       && (open->delim
1678           /* TODO uncomment this code when F2003 support is finished */
1679           /* || open->decimal || open->encoding || open->round
1680              || open->sign */
1681           || open->pad || open->blank)
1682       && strncasecmp (open->form->value.character.string,
1683                       "unformatted", 11) == 0)
1684     {
1685       const char *spec = (open->delim ? "DELIM "
1686                                       : (open->pad ? "PAD " : open->blank
1687                                                             ? "BLANK " : ""));
1688
1689       warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
1690                      "unformatted I/O", spec);
1691     }
1692
1693   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
1694       && strncasecmp (open->access->value.character.string, "stream", 6) == 0)
1695     {
1696       warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
1697                      "stream I/O");
1698     }
1699
1700   if (open->position
1701       && open->access && open->access->expr_type == EXPR_CONSTANT
1702       && !(strncasecmp (open->access->value.character.string,
1703                         "sequential", 10) == 0
1704            || strncasecmp (open->access->value.character.string,
1705                            "stream", 6) == 0
1706            || strncasecmp (open->access->value.character.string,
1707                            "append", 6) == 0))
1708     {
1709       warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
1710                      "for stream or sequential ACCESS");
1711     }
1712
1713 #undef warn_or_error
1714
1715   new_st.op = EXEC_OPEN;
1716   new_st.ext.open = open;
1717   return MATCH_YES;
1718
1719 syntax:
1720   gfc_syntax_error (ST_OPEN);
1721
1722 cleanup:
1723   gfc_free_open (open);
1724   return MATCH_ERROR;
1725 }
1726
1727
1728 /* Free a gfc_close structure an all its expressions.  */
1729
1730 void
1731 gfc_free_close (gfc_close *close)
1732 {
1733   if (close == NULL)
1734     return;
1735
1736   gfc_free_expr (close->unit);
1737   gfc_free_expr (close->iomsg);
1738   gfc_free_expr (close->iostat);
1739   gfc_free_expr (close->status);
1740   gfc_free (close);
1741 }
1742
1743
1744 /* Match elements of a CLOSE statement.  */
1745
1746 static match
1747 match_close_element (gfc_close *close)
1748 {
1749   match m;
1750
1751   m = match_etag (&tag_unit, &close->unit);
1752   if (m != MATCH_NO)
1753     return m;
1754   m = match_etag (&tag_status, &close->status);
1755   if (m != MATCH_NO)
1756     return m;
1757   m = match_out_tag (&tag_iomsg, &close->iomsg);
1758   if (m != MATCH_NO)
1759     return m;
1760   m = match_out_tag (&tag_iostat, &close->iostat);
1761   if (m != MATCH_NO)
1762     return m;
1763   m = match_ltag (&tag_err, &close->err);
1764   if (m != MATCH_NO)
1765     return m;
1766
1767   return MATCH_NO;
1768 }
1769
1770
1771 /* Match a CLOSE statement.  */
1772
1773 match
1774 gfc_match_close (void)
1775 {
1776   gfc_close *close;
1777   match m;
1778   bool warn;
1779
1780   m = gfc_match_char ('(');
1781   if (m == MATCH_NO)
1782     return m;
1783
1784   close = gfc_getmem (sizeof (gfc_close));
1785
1786   m = match_close_element (close);
1787
1788   if (m == MATCH_ERROR)
1789     goto cleanup;
1790   if (m == MATCH_NO)
1791     {
1792       m = gfc_match_expr (&close->unit);
1793       if (m == MATCH_NO)
1794         goto syntax;
1795       if (m == MATCH_ERROR)
1796         goto cleanup;
1797     }
1798
1799   for (;;)
1800     {
1801       if (gfc_match_char (')') == MATCH_YES)
1802         break;
1803       if (gfc_match_char (',') != MATCH_YES)
1804         goto syntax;
1805
1806       m = match_close_element (close);
1807       if (m == MATCH_ERROR)
1808         goto cleanup;
1809       if (m == MATCH_NO)
1810         goto syntax;
1811     }
1812
1813   if (gfc_match_eos () == MATCH_NO)
1814     goto syntax;
1815
1816   if (gfc_pure (NULL))
1817     {
1818       gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
1819       goto cleanup;
1820     }
1821
1822   warn = (close->iostat || close->err) ? true : false;
1823
1824   /* Checks on the STATUS specifier.  */
1825   if (close->status && close->status->expr_type == EXPR_CONSTANT)
1826     {
1827       static const char *status[] = { "KEEP", "DELETE", NULL };
1828
1829       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
1830                                       close->status->value.character.string,
1831                                       "CLOSE", warn))
1832         goto cleanup;
1833     }
1834
1835   new_st.op = EXEC_CLOSE;
1836   new_st.ext.close = close;
1837   return MATCH_YES;
1838
1839 syntax:
1840   gfc_syntax_error (ST_CLOSE);
1841
1842 cleanup:
1843   gfc_free_close (close);
1844   return MATCH_ERROR;
1845 }
1846
1847
1848 /* Resolve everything in a gfc_close structure.  */
1849
1850 try
1851 gfc_resolve_close (gfc_close *close)
1852 {
1853   RESOLVE_TAG (&tag_unit, close->unit);
1854   RESOLVE_TAG (&tag_iomsg, close->iomsg);
1855   RESOLVE_TAG (&tag_iostat, close->iostat);
1856   RESOLVE_TAG (&tag_status, close->status);
1857
1858   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
1859     return FAILURE;
1860
1861   return SUCCESS;
1862 }
1863
1864
1865 /* Free a gfc_filepos structure.  */
1866
1867 void
1868 gfc_free_filepos (gfc_filepos *fp)
1869 {
1870   gfc_free_expr (fp->unit);
1871   gfc_free_expr (fp->iomsg);
1872   gfc_free_expr (fp->iostat);
1873   gfc_free (fp);
1874 }
1875
1876
1877 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
1878
1879 static match
1880 match_file_element (gfc_filepos *fp)
1881 {
1882   match m;
1883
1884   m = match_etag (&tag_unit, &fp->unit);
1885   if (m != MATCH_NO)
1886     return m;
1887   m = match_out_tag (&tag_iomsg, &fp->iomsg);
1888   if (m != MATCH_NO)
1889     return m;
1890   m = match_out_tag (&tag_iostat, &fp->iostat);
1891   if (m != MATCH_NO)
1892     return m;
1893   m = match_ltag (&tag_err, &fp->err);
1894   if (m != MATCH_NO)
1895     return m;
1896
1897   return MATCH_NO;
1898 }
1899
1900
1901 /* Match the second half of the file-positioning statements, REWIND,
1902    BACKSPACE, ENDFILE, or the FLUSH statement.  */
1903
1904 static match
1905 match_filepos (gfc_statement st, gfc_exec_op op)
1906 {
1907   gfc_filepos *fp;
1908   match m;
1909
1910   fp = gfc_getmem (sizeof (gfc_filepos));
1911
1912   if (gfc_match_char ('(') == MATCH_NO)
1913     {
1914       m = gfc_match_expr (&fp->unit);
1915       if (m == MATCH_ERROR)
1916         goto cleanup;
1917       if (m == MATCH_NO)
1918         goto syntax;
1919
1920       goto done;
1921     }
1922
1923   m = match_file_element (fp);
1924   if (m == MATCH_ERROR)
1925     goto done;
1926   if (m == MATCH_NO)
1927     {
1928       m = gfc_match_expr (&fp->unit);
1929       if (m == MATCH_ERROR)
1930         goto done;
1931       if (m == MATCH_NO)
1932         goto syntax;
1933     }
1934
1935   for (;;)
1936     {
1937       if (gfc_match_char (')') == MATCH_YES)
1938         break;
1939       if (gfc_match_char (',') != MATCH_YES)
1940         goto syntax;
1941
1942       m = match_file_element (fp);
1943       if (m == MATCH_ERROR)
1944         goto cleanup;
1945       if (m == MATCH_NO)
1946         goto syntax;
1947     }
1948
1949 done:
1950   if (gfc_match_eos () != MATCH_YES)
1951     goto syntax;
1952
1953   if (gfc_pure (NULL))
1954     {
1955       gfc_error ("%s statement not allowed in PURE procedure at %C",
1956                  gfc_ascii_statement (st));
1957
1958       goto cleanup;
1959     }
1960
1961   new_st.op = op;
1962   new_st.ext.filepos = fp;
1963   return MATCH_YES;
1964
1965 syntax:
1966   gfc_syntax_error (st);
1967
1968 cleanup:
1969   gfc_free_filepos (fp);
1970   return MATCH_ERROR;
1971 }
1972
1973
1974 try
1975 gfc_resolve_filepos (gfc_filepos *fp)
1976 {
1977   RESOLVE_TAG (&tag_unit, fp->unit);
1978   RESOLVE_TAG (&tag_iostat, fp->iostat);
1979   RESOLVE_TAG (&tag_iomsg, fp->iomsg);
1980   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
1981     return FAILURE;
1982
1983   return SUCCESS;
1984 }
1985
1986
1987 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
1988    and the FLUSH statement.  */
1989
1990 match
1991 gfc_match_endfile (void)
1992 {
1993   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
1994 }
1995
1996 match
1997 gfc_match_backspace (void)
1998 {
1999   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2000 }
2001
2002 match
2003 gfc_match_rewind (void)
2004 {
2005   return match_filepos (ST_REWIND, EXEC_REWIND);
2006 }
2007
2008 match
2009 gfc_match_flush (void)
2010 {
2011   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2012       == FAILURE)
2013     return MATCH_ERROR;
2014
2015   return match_filepos (ST_FLUSH, EXEC_FLUSH);
2016 }
2017
2018 /******************** Data Transfer Statements *********************/
2019
2020 typedef enum
2021 { M_READ, M_WRITE, M_PRINT, M_INQUIRE }
2022 io_kind;
2023
2024
2025 /* Return a default unit number.  */
2026
2027 static gfc_expr *
2028 default_unit (io_kind k)
2029 {
2030   int unit;
2031
2032   if (k == M_READ)
2033     unit = 5;
2034   else
2035     unit = 6;
2036
2037   return gfc_int_expr (unit);
2038 }
2039
2040
2041 /* Match a unit specification for a data transfer statement.  */
2042
2043 static match
2044 match_dt_unit (io_kind k, gfc_dt *dt)
2045 {
2046   gfc_expr *e;
2047
2048   if (gfc_match_char ('*') == MATCH_YES)
2049     {
2050       if (dt->io_unit != NULL)
2051         goto conflict;
2052
2053       dt->io_unit = default_unit (k);
2054       return MATCH_YES;
2055     }
2056
2057   if (gfc_match_expr (&e) == MATCH_YES)
2058     {
2059       if (dt->io_unit != NULL)
2060         {
2061           gfc_free_expr (e);
2062           goto conflict;
2063         }
2064
2065       dt->io_unit = e;
2066       return MATCH_YES;
2067     }
2068
2069   return MATCH_NO;
2070
2071 conflict:
2072   gfc_error ("Duplicate UNIT specification at %C");
2073   return MATCH_ERROR;
2074 }
2075
2076
2077 /* Match a format specification.  */
2078
2079 static match
2080 match_dt_format (gfc_dt *dt)
2081 {
2082   locus where;
2083   gfc_expr *e;
2084   gfc_st_label *label;
2085   match m;
2086
2087   where = gfc_current_locus;
2088
2089   if (gfc_match_char ('*') == MATCH_YES)
2090     {
2091       if (dt->format_expr != NULL || dt->format_label != NULL)
2092         goto conflict;
2093
2094       dt->format_label = &format_asterisk;
2095       return MATCH_YES;
2096     }
2097
2098   if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2099     {
2100       if (dt->format_expr != NULL || dt->format_label != NULL)
2101         {
2102           gfc_free_st_label (label);
2103           goto conflict;
2104         }
2105
2106       if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2107         return MATCH_ERROR;
2108
2109       dt->format_label = label;
2110       return MATCH_YES;
2111     }
2112   else if (m == MATCH_ERROR)
2113     /* The label was zero or too large.  Emit the correct diagnosis.  */
2114     return MATCH_ERROR;
2115
2116   if (gfc_match_expr (&e) == MATCH_YES)
2117     {
2118       if (dt->format_expr != NULL || dt->format_label != NULL)
2119         {
2120           gfc_free_expr (e);
2121           goto conflict;
2122         }
2123       dt->format_expr = e;
2124       return MATCH_YES;
2125     }
2126
2127   gfc_current_locus = where;    /* The only case where we have to restore */
2128
2129   return MATCH_NO;
2130
2131 conflict:
2132   gfc_error ("Duplicate format specification at %C");
2133   return MATCH_ERROR;
2134 }
2135
2136
2137 /* Traverse a namelist that is part of a READ statement to make sure
2138    that none of the variables in the namelist are INTENT(IN).  Returns
2139    nonzero if we find such a variable.  */
2140
2141 static int
2142 check_namelist (gfc_symbol *sym)
2143 {
2144   gfc_namelist *p;
2145
2146   for (p = sym->namelist; p; p = p->next)
2147     if (p->sym->attr.intent == INTENT_IN)
2148       {
2149         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2150                    p->sym->name, sym->name);
2151         return 1;
2152       }
2153
2154   return 0;
2155 }
2156
2157
2158 /* Match a single data transfer element.  */
2159
2160 static match
2161 match_dt_element (io_kind k, gfc_dt *dt)
2162 {
2163   char name[GFC_MAX_SYMBOL_LEN + 1];
2164   gfc_symbol *sym;
2165   match m;
2166
2167   if (gfc_match (" unit =") == MATCH_YES)
2168     {
2169       m = match_dt_unit (k, dt);
2170       if (m != MATCH_NO)
2171         return m;
2172     }
2173
2174   if (gfc_match (" fmt =") == MATCH_YES)
2175     {
2176       m = match_dt_format (dt);
2177       if (m != MATCH_NO)
2178         return m;
2179     }
2180
2181   if (gfc_match (" nml = %n", name) == MATCH_YES)
2182     {
2183       if (dt->namelist != NULL)
2184         {
2185           gfc_error ("Duplicate NML specification at %C");
2186           return MATCH_ERROR;
2187         }
2188
2189       if (gfc_find_symbol (name, NULL, 1, &sym))
2190         return MATCH_ERROR;
2191
2192       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2193         {
2194           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2195                      sym != NULL ? sym->name : name);
2196           return MATCH_ERROR;
2197         }
2198
2199       dt->namelist = sym;
2200       if (k == M_READ && check_namelist (sym))
2201         return MATCH_ERROR;
2202
2203       return MATCH_YES;
2204     }
2205
2206   m = match_etag (&tag_rec, &dt->rec);
2207   if (m != MATCH_NO)
2208     return m;
2209   m = match_etag (&tag_spos, &dt->rec);
2210   if (m != MATCH_NO)
2211     return m;
2212   m = match_out_tag (&tag_iomsg, &dt->iomsg);
2213   if (m != MATCH_NO)
2214     return m;
2215   m = match_out_tag (&tag_iostat, &dt->iostat);
2216   if (m != MATCH_NO)
2217     return m;
2218   m = match_ltag (&tag_err, &dt->err);
2219   if (m == MATCH_YES)
2220     dt->err_where = gfc_current_locus;
2221   if (m != MATCH_NO)
2222     return m;
2223   m = match_etag (&tag_advance, &dt->advance);
2224   if (m != MATCH_NO)
2225     return m;
2226   m = match_out_tag (&tag_size, &dt->size);
2227   if (m != MATCH_NO)
2228     return m;
2229
2230   m = match_ltag (&tag_end, &dt->end);
2231   if (m == MATCH_YES)
2232     {
2233       if (k == M_WRITE)
2234        {
2235          gfc_error ("END tag at %C not allowed in output statement");
2236          return MATCH_ERROR;
2237        }
2238       dt->end_where = gfc_current_locus;
2239     }
2240   if (m != MATCH_NO)
2241     return m;
2242
2243   m = match_ltag (&tag_eor, &dt->eor);
2244   if (m == MATCH_YES)
2245     dt->eor_where = gfc_current_locus;
2246   if (m != MATCH_NO)
2247     return m;
2248
2249   return MATCH_NO;
2250 }
2251
2252
2253 /* Free a data transfer structure and everything below it.  */
2254
2255 void
2256 gfc_free_dt (gfc_dt *dt)
2257 {
2258   if (dt == NULL)
2259     return;
2260
2261   gfc_free_expr (dt->io_unit);
2262   gfc_free_expr (dt->format_expr);
2263   gfc_free_expr (dt->rec);
2264   gfc_free_expr (dt->advance);
2265   gfc_free_expr (dt->iomsg);
2266   gfc_free_expr (dt->iostat);
2267   gfc_free_expr (dt->size);
2268   gfc_free (dt);
2269 }
2270
2271
2272 /* Resolve everything in a gfc_dt structure.  */
2273
2274 try
2275 gfc_resolve_dt (gfc_dt *dt)
2276 {
2277   gfc_expr *e;
2278
2279   RESOLVE_TAG (&tag_format, dt->format_expr);
2280   RESOLVE_TAG (&tag_rec, dt->rec);
2281   RESOLVE_TAG (&tag_spos, dt->rec);
2282   RESOLVE_TAG (&tag_advance, dt->advance);
2283   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2284   RESOLVE_TAG (&tag_iostat, dt->iostat);
2285   RESOLVE_TAG (&tag_size, dt->size);
2286
2287   e = dt->io_unit;
2288   if (gfc_resolve_expr (e) == SUCCESS
2289       && (e->ts.type != BT_INTEGER
2290           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2291     {
2292       gfc_error ("UNIT specification at %L must be an INTEGER expression "
2293                  "or a CHARACTER variable", &e->where);
2294       return FAILURE;
2295     }
2296
2297   if (e->ts.type == BT_CHARACTER)
2298     {
2299       if (gfc_has_vector_index (e))
2300         {
2301           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2302           return FAILURE;
2303         }
2304     }
2305
2306   if (e->rank && e->ts.type != BT_CHARACTER)
2307     {
2308       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2309       return FAILURE;
2310     }
2311
2312   if (dt->err)
2313     {
2314       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2315         return FAILURE;
2316       if (dt->err->defined == ST_LABEL_UNKNOWN)
2317         {
2318           gfc_error ("ERR tag label %d at %L not defined",
2319                       dt->err->value, &dt->err_where);
2320           return FAILURE;
2321         }
2322     }
2323
2324   if (dt->end)
2325     {
2326       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2327         return FAILURE;
2328       if (dt->end->defined == ST_LABEL_UNKNOWN)
2329         {
2330           gfc_error ("END tag label %d at %L not defined",
2331                       dt->end->value, &dt->end_where);
2332           return FAILURE;
2333         }
2334     }
2335
2336   if (dt->eor)
2337     {
2338       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2339         return FAILURE;
2340       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2341         {
2342           gfc_error ("EOR tag label %d at %L not defined",
2343                       dt->eor->value, &dt->eor_where);
2344           return FAILURE;
2345         }
2346     }
2347
2348   /* Check the format label actually exists.  */
2349   if (dt->format_label && dt->format_label != &format_asterisk
2350       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2351     {
2352       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2353                  &dt->format_label->where);
2354       return FAILURE;
2355     }
2356   return SUCCESS;
2357 }
2358
2359
2360 /* Given an io_kind, return its name.  */
2361
2362 static const char *
2363 io_kind_name (io_kind k)
2364 {
2365   const char *name;
2366
2367   switch (k)
2368     {
2369     case M_READ:
2370       name = "READ";
2371       break;
2372     case M_WRITE:
2373       name = "WRITE";
2374       break;
2375     case M_PRINT:
2376       name = "PRINT";
2377       break;
2378     case M_INQUIRE:
2379       name = "INQUIRE";
2380       break;
2381     default:
2382       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2383     }
2384
2385   return name;
2386 }
2387
2388
2389 /* Match an IO iteration statement of the form:
2390
2391    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2392
2393    which is equivalent to a single IO element.  This function is
2394    mutually recursive with match_io_element().  */
2395
2396 static match match_io_element (io_kind, gfc_code **);
2397
2398 static match
2399 match_io_iterator (io_kind k, gfc_code **result)
2400 {
2401   gfc_code *head, *tail, *new;
2402   gfc_iterator *iter;
2403   locus old_loc;
2404   match m;
2405   int n;
2406
2407   iter = NULL;
2408   head = NULL;
2409   old_loc = gfc_current_locus;
2410
2411   if (gfc_match_char ('(') != MATCH_YES)
2412     return MATCH_NO;
2413
2414   m = match_io_element (k, &head);
2415   tail = head;
2416
2417   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2418     {
2419       m = MATCH_NO;
2420       goto cleanup;
2421     }
2422
2423   /* Can't be anything but an IO iterator.  Build a list.  */
2424   iter = gfc_get_iterator ();
2425
2426   for (n = 1;; n++)
2427     {
2428       m = gfc_match_iterator (iter, 0);
2429       if (m == MATCH_ERROR)
2430         goto cleanup;
2431       if (m == MATCH_YES)
2432         {
2433           gfc_check_do_variable (iter->var->symtree);
2434           break;
2435         }
2436
2437       m = match_io_element (k, &new);
2438       if (m == MATCH_ERROR)
2439         goto cleanup;
2440       if (m == MATCH_NO)
2441         {
2442           if (n > 2)
2443             goto syntax;
2444           goto cleanup;
2445         }
2446
2447       tail = gfc_append_code (tail, new);
2448
2449       if (gfc_match_char (',') != MATCH_YES)
2450         {
2451           if (n > 2)
2452             goto syntax;
2453           m = MATCH_NO;
2454           goto cleanup;
2455         }
2456     }
2457
2458   if (gfc_match_char (')') != MATCH_YES)
2459     goto syntax;
2460
2461   new = gfc_get_code ();
2462   new->op = EXEC_DO;
2463   new->ext.iterator = iter;
2464
2465   new->block = gfc_get_code ();
2466   new->block->op = EXEC_DO;
2467   new->block->next = head;
2468
2469   *result = new;
2470   return MATCH_YES;
2471
2472 syntax:
2473   gfc_error ("Syntax error in I/O iterator at %C");
2474   m = MATCH_ERROR;
2475
2476 cleanup:
2477   gfc_free_iterator (iter, 1);
2478   gfc_free_statements (head);
2479   gfc_current_locus = old_loc;
2480   return m;
2481 }
2482
2483
2484 /* Match a single element of an IO list, which is either a single
2485    expression or an IO Iterator.  */
2486
2487 static match
2488 match_io_element (io_kind k, gfc_code **cpp)
2489 {
2490   gfc_expr *expr;
2491   gfc_code *cp;
2492   match m;
2493
2494   expr = NULL;
2495
2496   m = match_io_iterator (k, cpp);
2497   if (m == MATCH_YES)
2498     return MATCH_YES;
2499
2500   if (k == M_READ)
2501     {
2502       m = gfc_match_variable (&expr, 0);
2503       if (m == MATCH_NO)
2504         gfc_error ("Expected variable in READ statement at %C");
2505     }
2506   else
2507     {
2508       m = gfc_match_expr (&expr);
2509       if (m == MATCH_NO)
2510         gfc_error ("Expected expression in %s statement at %C",
2511                    io_kind_name (k));
2512     }
2513
2514   if (m == MATCH_YES)
2515     switch (k)
2516       {
2517       case M_READ:
2518         if (expr->symtree->n.sym->attr.intent == INTENT_IN)
2519           {
2520             gfc_error ("Variable '%s' in input list at %C cannot be "
2521                        "INTENT(IN)", expr->symtree->n.sym->name);
2522             m = MATCH_ERROR;
2523           }
2524
2525         if (gfc_pure (NULL)
2526             && gfc_impure_variable (expr->symtree->n.sym)
2527             && current_dt->io_unit->ts.type == BT_CHARACTER)
2528           {
2529             gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
2530                        expr->symtree->n.sym->name);
2531             m = MATCH_ERROR;
2532           }
2533
2534         if (gfc_check_do_variable (expr->symtree))
2535           m = MATCH_ERROR;
2536
2537         break;
2538
2539       case M_WRITE:
2540         if (current_dt->io_unit->ts.type == BT_CHARACTER
2541             && gfc_pure (NULL)
2542             && current_dt->io_unit->expr_type == EXPR_VARIABLE
2543             && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
2544           {
2545             gfc_error ("Cannot write to internal file unit '%s' at %C "
2546                        "inside a PURE procedure",
2547                        current_dt->io_unit->symtree->n.sym->name);
2548             m = MATCH_ERROR;
2549           }
2550
2551         break;
2552
2553       default:
2554         break;
2555       }
2556
2557   if (m != MATCH_YES)
2558     {
2559       gfc_free_expr (expr);
2560       return MATCH_ERROR;
2561     }
2562
2563   cp = gfc_get_code ();
2564   cp->op = EXEC_TRANSFER;
2565   cp->expr = expr;
2566
2567   *cpp = cp;
2568   return MATCH_YES;
2569 }
2570
2571
2572 /* Match an I/O list, building gfc_code structures as we go.  */
2573
2574 static match
2575 match_io_list (io_kind k, gfc_code **head_p)
2576 {
2577   gfc_code *head, *tail, *new;
2578   match m;
2579
2580   *head_p = head = tail = NULL;
2581   if (gfc_match_eos () == MATCH_YES)
2582     return MATCH_YES;
2583
2584   for (;;)
2585     {
2586       m = match_io_element (k, &new);
2587       if (m == MATCH_ERROR)
2588         goto cleanup;
2589       if (m == MATCH_NO)
2590         goto syntax;
2591
2592       tail = gfc_append_code (tail, new);
2593       if (head == NULL)
2594         head = new;
2595
2596       if (gfc_match_eos () == MATCH_YES)
2597         break;
2598       if (gfc_match_char (',') != MATCH_YES)
2599         goto syntax;
2600     }
2601
2602   *head_p = head;
2603   return MATCH_YES;
2604
2605 syntax:
2606   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2607
2608 cleanup:
2609   gfc_free_statements (head);
2610   return MATCH_ERROR;
2611 }
2612
2613
2614 /* Attach the data transfer end node.  */
2615
2616 static void
2617 terminate_io (gfc_code *io_code)
2618 {
2619   gfc_code *c;
2620
2621   if (io_code == NULL)
2622     io_code = new_st.block;
2623
2624   c = gfc_get_code ();
2625   c->op = EXEC_DT_END;
2626
2627   /* Point to structure that is already there */
2628   c->ext.dt = new_st.ext.dt;
2629   gfc_append_code (io_code, c);
2630 }
2631
2632
2633 /* Check the constraints for a data transfer statement.  The majority of the
2634    constraints appearing in 9.4 of the standard appear here.  Some are handled
2635    in resolve_tag and others in gfc_resolve_dt.  */
2636
2637 static match
2638 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
2639                       locus *spec_end)
2640 {
2641 #define io_constraint(condition,msg,arg)\
2642 if (condition) \
2643   {\
2644     gfc_error(msg,arg);\
2645     m = MATCH_ERROR;\
2646   }
2647
2648   match m;
2649   gfc_expr *expr;
2650   gfc_symbol *sym = NULL;
2651
2652   m = MATCH_YES;
2653
2654   expr = dt->io_unit;
2655   if (expr && expr->expr_type == EXPR_VARIABLE
2656       && expr->ts.type == BT_CHARACTER)
2657     {
2658       sym = expr->symtree->n.sym;
2659
2660       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
2661                      "Internal file at %L must not be INTENT(IN)",
2662                      &expr->where);
2663
2664       io_constraint (gfc_has_vector_index (dt->io_unit),
2665                      "Internal file incompatible with vector subscript at %L",
2666                      &expr->where);
2667
2668       io_constraint (dt->rec != NULL,
2669                      "REC tag at %L is incompatible with internal file",
2670                      &dt->rec->where);
2671
2672       if (dt->namelist != NULL)
2673         {
2674           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
2675                               "at %L with namelist", &expr->where)
2676               == FAILURE)
2677             m = MATCH_ERROR;
2678         }
2679
2680       io_constraint (dt->advance != NULL,
2681                      "ADVANCE tag at %L is incompatible with internal file",
2682                      &dt->advance->where);
2683     }
2684
2685   if (expr && expr->ts.type != BT_CHARACTER)
2686     {
2687
2688       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
2689                      "IO UNIT in %s statement at %C must be "
2690                      "an internal file in a PURE procedure",
2691                      io_kind_name (k));
2692     }
2693
2694
2695   if (k != M_READ)
2696     {
2697       io_constraint (dt->end, "END tag not allowed with output at %L",
2698                      &dt->end_where);
2699
2700       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
2701                      &dt->eor_where);
2702
2703       io_constraint (k != M_READ && dt->size,
2704                      "SIZE=specifier not allowed with output at %L",
2705                      &dt->size->where);
2706     }
2707   else
2708     {
2709       io_constraint (dt->size && dt->advance == NULL,
2710                      "SIZE tag at %L requires an ADVANCE tag",
2711                      &dt->size->where);
2712
2713       io_constraint (dt->eor && dt->advance == NULL,
2714                      "EOR tag at %L requires an ADVANCE tag",
2715                      &dt->eor_where);
2716     }
2717
2718
2719
2720   if (dt->namelist)
2721     {
2722       io_constraint (io_code && dt->namelist,
2723                      "NAMELIST cannot be followed by IO-list at %L",
2724                      &io_code->loc);
2725
2726       io_constraint (dt->format_expr,
2727                      "IO spec-list cannot contain both NAMELIST group name "
2728                      "and format specification at %L.",
2729                      &dt->format_expr->where);
2730
2731       io_constraint (dt->format_label,
2732                      "IO spec-list cannot contain both NAMELIST group name "
2733                      "and format label at %L", spec_end);
2734
2735       io_constraint (dt->rec,
2736                      "NAMELIST IO is not allowed with a REC=specifier "
2737                      "at %L.", &dt->rec->where);
2738
2739       io_constraint (dt->advance,
2740                      "NAMELIST IO is not allowed with a ADVANCE=specifier "
2741                      "at %L.", &dt->advance->where);
2742     }
2743
2744   if (dt->rec)
2745     {
2746       io_constraint (dt->end,
2747                      "An END tag is not allowed with a "
2748                      "REC=specifier at %L.", &dt->end_where);
2749
2750
2751       io_constraint (dt->format_label == &format_asterisk,
2752                      "FMT=* is not allowed with a REC=specifier "
2753                      "at %L.", spec_end);
2754     }
2755
2756   if (dt->advance)
2757     {
2758       int not_yes, not_no;
2759       expr = dt->advance;
2760
2761       io_constraint (dt->format_label == &format_asterisk,
2762                      "List directed format(*) is not allowed with a "
2763                      "ADVANCE=specifier at %L.", &expr->where);
2764
2765       io_constraint (dt->format_expr == NULL && dt->format_label == NULL
2766                      && dt->namelist == NULL,
2767                      "the ADVANCE=specifier at %L must appear with an "
2768                      "explicit format expression", &expr->where);
2769
2770       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
2771         {
2772           const char * advance = expr->value.character.string;
2773           not_no = strcasecmp (advance, "no") != 0;
2774           not_yes = strcasecmp (advance, "yes") != 0;
2775         }
2776       else
2777         {
2778           not_no = 0;
2779           not_yes = 0;
2780         }
2781
2782       io_constraint (not_no && not_yes,
2783                      "ADVANCE=specifier at %L must have value = "
2784                      "YES or NO.", &expr->where);
2785
2786       io_constraint (dt->size && not_no && k == M_READ,
2787                      "SIZE tag at %L requires an ADVANCE = 'NO'",
2788                      &dt->size->where);
2789
2790       io_constraint (dt->eor && not_no && k == M_READ,
2791                      "EOR tag at %L requires an ADVANCE = 'NO'",
2792                      &dt->eor_where);
2793     }
2794
2795   expr = dt->format_expr;
2796   if (gfc_simplify_expr (expr, 0) == FAILURE
2797       || check_format_string (expr, k == M_READ) == FAILURE)
2798     return MATCH_ERROR;
2799
2800   return m;
2801 }
2802 #undef io_constraint
2803
2804
2805 /* Match a READ, WRITE or PRINT statement.  */
2806
2807 static match
2808 match_io (io_kind k)
2809 {
2810   char name[GFC_MAX_SYMBOL_LEN + 1];
2811   gfc_code *io_code;
2812   gfc_symbol *sym;
2813   int comma_flag, c;
2814   locus where;
2815   locus spec_end;
2816   gfc_dt *dt;
2817   match m;
2818
2819   where = gfc_current_locus;
2820   comma_flag = 0;
2821   current_dt = dt = gfc_getmem (sizeof (gfc_dt));
2822   m = gfc_match_char ('(');
2823   if (m == MATCH_NO)
2824     {
2825       where = gfc_current_locus;
2826       if (k == M_WRITE)
2827         goto syntax;
2828       else if (k == M_PRINT)
2829         {
2830           /* Treat the non-standard case of PRINT namelist.  */
2831           if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
2832               && gfc_match_name (name) == MATCH_YES)
2833             {
2834               gfc_find_symbol (name, NULL, 1, &sym);
2835               if (sym && sym->attr.flavor == FL_NAMELIST)
2836                 {
2837                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
2838                                       "%C is an extension") == FAILURE)
2839                     {
2840                       m = MATCH_ERROR;
2841                       goto cleanup;
2842                     }
2843
2844                   dt->io_unit = default_unit (k);
2845                   dt->namelist = sym;
2846                   goto get_io_list;
2847                 }
2848               else
2849                 gfc_current_locus = where;
2850             }
2851         }
2852
2853       if (gfc_current_form == FORM_FREE)
2854         {
2855           c = gfc_peek_char();
2856           if (c != ' ' && c != '*' && c != '\'' && c != '"')
2857             {
2858               m = MATCH_NO;
2859               goto cleanup;
2860             }
2861         }
2862
2863       m = match_dt_format (dt);
2864       if (m == MATCH_ERROR)
2865         goto cleanup;
2866       if (m == MATCH_NO)
2867         goto syntax;
2868
2869       comma_flag = 1;
2870       dt->io_unit = default_unit (k);
2871       goto get_io_list;
2872     }
2873   else
2874     {
2875       /* Before issuing an error for a malformed 'print (1,*)' type of
2876          error, check for a default-char-expr of the form ('(I0)').  */
2877       if (k == M_PRINT && m == MATCH_YES)
2878         {
2879           /* Reset current locus to get the initial '(' in an expression.  */
2880           gfc_current_locus = where;
2881           dt->format_expr = NULL;
2882           m = match_dt_format (dt);
2883
2884           if (m == MATCH_ERROR)
2885             goto cleanup;
2886           if (m == MATCH_NO || dt->format_expr == NULL)
2887             goto syntax;
2888
2889           comma_flag = 1;
2890           dt->io_unit = default_unit (k);
2891           goto get_io_list;
2892         }
2893     }
2894
2895   /* Match a control list */
2896   if (match_dt_element (k, dt) == MATCH_YES)
2897     goto next;
2898   if (match_dt_unit (k, dt) != MATCH_YES)
2899     goto loop;
2900
2901   if (gfc_match_char (')') == MATCH_YES)
2902     goto get_io_list;
2903   if (gfc_match_char (',') != MATCH_YES)
2904     goto syntax;
2905
2906   m = match_dt_element (k, dt);
2907   if (m == MATCH_YES)
2908     goto next;
2909   if (m == MATCH_ERROR)
2910     goto cleanup;
2911
2912   m = match_dt_format (dt);
2913   if (m == MATCH_YES)
2914     goto next;
2915   if (m == MATCH_ERROR)
2916     goto cleanup;
2917
2918   where = gfc_current_locus;
2919
2920   m = gfc_match_name (name);
2921   if (m == MATCH_YES)
2922     {
2923       gfc_find_symbol (name, NULL, 1, &sym);
2924       if (sym && sym->attr.flavor == FL_NAMELIST)
2925         {
2926           dt->namelist = sym;
2927           if (k == M_READ && check_namelist (sym))
2928             {
2929               m = MATCH_ERROR;
2930               goto cleanup;
2931             }
2932           goto next;
2933         }
2934     }
2935
2936   gfc_current_locus = where;
2937
2938   goto loop;                    /* No matches, try regular elements */
2939
2940 next:
2941   if (gfc_match_char (')') == MATCH_YES)
2942     goto get_io_list;
2943   if (gfc_match_char (',') != MATCH_YES)
2944     goto syntax;
2945
2946 loop:
2947   for (;;)
2948     {
2949       m = match_dt_element (k, dt);
2950       if (m == MATCH_NO)
2951         goto syntax;
2952       if (m == MATCH_ERROR)
2953         goto cleanup;
2954
2955       if (gfc_match_char (')') == MATCH_YES)
2956         break;
2957       if (gfc_match_char (',') != MATCH_YES)
2958         goto syntax;
2959     }
2960
2961 get_io_list:
2962
2963   /* Used in check_io_constraints, where no locus is available.  */
2964   spec_end = gfc_current_locus;
2965
2966   /* Optional leading comma (non-standard).  */
2967   if (!comma_flag
2968       && gfc_match_char (',') == MATCH_YES
2969       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2970                          "item list at %C") == FAILURE)
2971     return MATCH_ERROR;
2972
2973   io_code = NULL;
2974   if (gfc_match_eos () != MATCH_YES)
2975     {
2976       if (comma_flag && gfc_match_char (',') != MATCH_YES)
2977         {
2978           gfc_error ("Expected comma in I/O list at %C");
2979           m = MATCH_ERROR;
2980           goto cleanup;
2981         }
2982
2983       m = match_io_list (k, &io_code);
2984       if (m == MATCH_ERROR)
2985         goto cleanup;
2986       if (m == MATCH_NO)
2987         goto syntax;
2988     }
2989
2990   /* A full IO statement has been matched.  Check the constraints.  spec_end is
2991      supplied for cases where no locus is supplied.  */
2992   m = check_io_constraints (k, dt, io_code, &spec_end);
2993
2994   if (m == MATCH_ERROR)
2995     goto cleanup;
2996
2997   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
2998   new_st.ext.dt = dt;
2999   new_st.block = gfc_get_code ();
3000   new_st.block->op = new_st.op;
3001   new_st.block->next = io_code;
3002
3003   terminate_io (io_code);
3004
3005   return MATCH_YES;
3006
3007 syntax:
3008   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3009   m = MATCH_ERROR;
3010
3011 cleanup:
3012   gfc_free_dt (dt);
3013   return m;
3014 }
3015
3016
3017 match
3018 gfc_match_read (void)
3019 {
3020   return match_io (M_READ);
3021 }
3022
3023 match
3024 gfc_match_write (void)
3025 {
3026   return match_io (M_WRITE);
3027 }
3028
3029 match
3030 gfc_match_print (void)
3031 {
3032   match m;
3033
3034   m = match_io (M_PRINT);
3035   if (m != MATCH_YES)
3036     return m;
3037
3038   if (gfc_pure (NULL))
3039     {
3040       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3041       return MATCH_ERROR;
3042     }
3043
3044   return MATCH_YES;
3045 }
3046
3047
3048 /* Free a gfc_inquire structure.  */
3049
3050 void
3051 gfc_free_inquire (gfc_inquire *inquire)
3052 {
3053
3054   if (inquire == NULL)
3055     return;
3056
3057   gfc_free_expr (inquire->unit);
3058   gfc_free_expr (inquire->file);
3059   gfc_free_expr (inquire->iomsg);
3060   gfc_free_expr (inquire->iostat);
3061   gfc_free_expr (inquire->exist);
3062   gfc_free_expr (inquire->opened);
3063   gfc_free_expr (inquire->number);
3064   gfc_free_expr (inquire->named);
3065   gfc_free_expr (inquire->name);
3066   gfc_free_expr (inquire->access);
3067   gfc_free_expr (inquire->sequential);
3068   gfc_free_expr (inquire->direct);
3069   gfc_free_expr (inquire->form);
3070   gfc_free_expr (inquire->formatted);
3071   gfc_free_expr (inquire->unformatted);
3072   gfc_free_expr (inquire->recl);
3073   gfc_free_expr (inquire->nextrec);
3074   gfc_free_expr (inquire->blank);
3075   gfc_free_expr (inquire->position);
3076   gfc_free_expr (inquire->action);
3077   gfc_free_expr (inquire->read);
3078   gfc_free_expr (inquire->write);
3079   gfc_free_expr (inquire->readwrite);
3080   gfc_free_expr (inquire->delim);
3081   gfc_free_expr (inquire->pad);
3082   gfc_free_expr (inquire->iolength);
3083   gfc_free_expr (inquire->convert);
3084   gfc_free_expr (inquire->strm_pos);
3085   gfc_free (inquire);
3086 }
3087
3088
3089 /* Match an element of an INQUIRE statement.  */
3090
3091 #define RETM   if (m != MATCH_NO) return m;
3092
3093 static match
3094 match_inquire_element (gfc_inquire *inquire)
3095 {
3096   match m;
3097
3098   m = match_etag (&tag_unit, &inquire->unit);
3099   RETM m = match_etag (&tag_file, &inquire->file);
3100   RETM m = match_ltag (&tag_err, &inquire->err);
3101   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3102   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3103   RETM m = match_vtag (&tag_exist, &inquire->exist);
3104   RETM m = match_vtag (&tag_opened, &inquire->opened);
3105   RETM m = match_vtag (&tag_named, &inquire->named);
3106   RETM m = match_vtag (&tag_name, &inquire->name);
3107   RETM m = match_out_tag (&tag_number, &inquire->number);
3108   RETM m = match_vtag (&tag_s_access, &inquire->access);
3109   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3110   RETM m = match_vtag (&tag_direct, &inquire->direct);
3111   RETM m = match_vtag (&tag_s_form, &inquire->form);
3112   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3113   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3114   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3115   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3116   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3117   RETM m = match_vtag (&tag_s_position, &inquire->position);
3118   RETM m = match_vtag (&tag_s_action, &inquire->action);
3119   RETM m = match_vtag (&tag_read, &inquire->read);
3120   RETM m = match_vtag (&tag_write, &inquire->write);
3121   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3122   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3123   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3124   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3125   RETM m = match_vtag (&tag_convert, &inquire->convert);
3126   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3127   RETM return MATCH_NO;
3128 }
3129
3130 #undef RETM
3131
3132
3133 match
3134 gfc_match_inquire (void)
3135 {
3136   gfc_inquire *inquire;
3137   gfc_code *code;
3138   match m;
3139   locus loc;
3140
3141   m = gfc_match_char ('(');
3142   if (m == MATCH_NO)
3143     return m;
3144
3145   inquire = gfc_getmem (sizeof (gfc_inquire));
3146
3147   loc = gfc_current_locus;
3148
3149   m = match_inquire_element (inquire);
3150   if (m == MATCH_ERROR)
3151     goto cleanup;
3152   if (m == MATCH_NO)
3153     {
3154       m = gfc_match_expr (&inquire->unit);
3155       if (m == MATCH_ERROR)
3156         goto cleanup;
3157       if (m == MATCH_NO)
3158         goto syntax;
3159     }
3160
3161   /* See if we have the IOLENGTH form of the inquire statement.  */
3162   if (inquire->iolength != NULL)
3163     {
3164       if (gfc_match_char (')') != MATCH_YES)
3165         goto syntax;
3166
3167       m = match_io_list (M_INQUIRE, &code);
3168       if (m == MATCH_ERROR)
3169         goto cleanup;
3170       if (m == MATCH_NO)
3171         goto syntax;
3172
3173       new_st.op = EXEC_IOLENGTH;
3174       new_st.expr = inquire->iolength;
3175       new_st.ext.inquire = inquire;
3176
3177       if (gfc_pure (NULL))
3178         {
3179           gfc_free_statements (code);
3180           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3181           return MATCH_ERROR;
3182         }
3183
3184       new_st.block = gfc_get_code ();
3185       new_st.block->op = EXEC_IOLENGTH;
3186       terminate_io (code);
3187       new_st.block->next = code;
3188       return MATCH_YES;
3189     }
3190
3191   /* At this point, we have the non-IOLENGTH inquire statement.  */
3192   for (;;)
3193     {
3194       if (gfc_match_char (')') == MATCH_YES)
3195         break;
3196       if (gfc_match_char (',') != MATCH_YES)
3197         goto syntax;
3198
3199       m = match_inquire_element (inquire);
3200       if (m == MATCH_ERROR)
3201         goto cleanup;
3202       if (m == MATCH_NO)
3203         goto syntax;
3204
3205       if (inquire->iolength != NULL)
3206         {
3207           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3208           goto cleanup;
3209         }
3210     }
3211
3212   if (gfc_match_eos () != MATCH_YES)
3213     goto syntax;
3214
3215   if (inquire->unit != NULL && inquire->file != NULL)
3216     {
3217       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3218                  "UNIT specifiers", &loc);
3219       goto cleanup;
3220     }
3221
3222   if (inquire->unit == NULL && inquire->file == NULL)
3223     {
3224       gfc_error ("INQUIRE statement at %L requires either FILE or "
3225                  "UNIT specifier", &loc);
3226       goto cleanup;
3227     }
3228
3229   if (gfc_pure (NULL))
3230     {
3231       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3232       goto cleanup;
3233     }
3234
3235   new_st.op = EXEC_INQUIRE;
3236   new_st.ext.inquire = inquire;
3237   return MATCH_YES;
3238
3239 syntax:
3240   gfc_syntax_error (ST_INQUIRE);
3241
3242 cleanup:
3243   gfc_free_inquire (inquire);
3244   return MATCH_ERROR;
3245 }
3246
3247
3248 /* Resolve everything in a gfc_inquire structure.  */
3249
3250 try
3251 gfc_resolve_inquire (gfc_inquire *inquire)
3252 {
3253   RESOLVE_TAG (&tag_unit, inquire->unit);
3254   RESOLVE_TAG (&tag_file, inquire->file);
3255   RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
3256   RESOLVE_TAG (&tag_iostat, inquire->iostat);
3257   RESOLVE_TAG (&tag_exist, inquire->exist);
3258   RESOLVE_TAG (&tag_opened, inquire->opened);
3259   RESOLVE_TAG (&tag_number, inquire->number);
3260   RESOLVE_TAG (&tag_named, inquire->named);
3261   RESOLVE_TAG (&tag_name, inquire->name);
3262   RESOLVE_TAG (&tag_s_access, inquire->access);
3263   RESOLVE_TAG (&tag_sequential, inquire->sequential);
3264   RESOLVE_TAG (&tag_direct, inquire->direct);
3265   RESOLVE_TAG (&tag_s_form, inquire->form);
3266   RESOLVE_TAG (&tag_formatted, inquire->formatted);
3267   RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
3268   RESOLVE_TAG (&tag_s_recl, inquire->recl);
3269   RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
3270   RESOLVE_TAG (&tag_s_blank, inquire->blank);
3271   RESOLVE_TAG (&tag_s_position, inquire->position);
3272   RESOLVE_TAG (&tag_s_action, inquire->action);
3273   RESOLVE_TAG (&tag_read, inquire->read);
3274   RESOLVE_TAG (&tag_write, inquire->write);
3275   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
3276   RESOLVE_TAG (&tag_s_delim, inquire->delim);
3277   RESOLVE_TAG (&tag_s_pad, inquire->pad);
3278   RESOLVE_TAG (&tag_iolength, inquire->iolength);
3279   RESOLVE_TAG (&tag_convert, inquire->convert);
3280   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
3281
3282   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
3283     return FAILURE;
3284
3285   return SUCCESS;
3286 }