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->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
2086   where = gfc_current_locus;
2087
2088   if (gfc_match_char ('*') == MATCH_YES)
2089     {
2090       if (dt->format_expr != NULL || dt->format_label != NULL)
2091         goto conflict;
2092
2093       dt->format_label = &format_asterisk;
2094       return MATCH_YES;
2095     }
2096
2097   if (gfc_match_st_label (&label) == MATCH_YES)
2098     {
2099       if (dt->format_expr != NULL || dt->format_label != NULL)
2100         {
2101           gfc_free_st_label (label);
2102           goto conflict;
2103         }
2104
2105       if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2106         return MATCH_ERROR;
2107
2108       dt->format_label = label;
2109       return MATCH_YES;
2110     }
2111
2112   if (gfc_match_expr (&e) == MATCH_YES)
2113     {
2114       if (dt->format_expr != NULL || dt->format_label != NULL)
2115         {
2116           gfc_free_expr (e);
2117           goto conflict;
2118         }
2119       dt->format_expr = e;
2120       return MATCH_YES;
2121     }
2122
2123   gfc_current_locus = where;    /* The only case where we have to restore */
2124
2125   return MATCH_NO;
2126
2127 conflict:
2128   gfc_error ("Duplicate format specification at %C");
2129   return MATCH_ERROR;
2130 }
2131
2132
2133 /* Traverse a namelist that is part of a READ statement to make sure
2134    that none of the variables in the namelist are INTENT(IN).  Returns
2135    nonzero if we find such a variable.  */
2136
2137 static int
2138 check_namelist (gfc_symbol *sym)
2139 {
2140   gfc_namelist *p;
2141
2142   for (p = sym->namelist; p; p = p->next)
2143     if (p->sym->attr.intent == INTENT_IN)
2144       {
2145         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2146                    p->sym->name, sym->name);
2147         return 1;
2148       }
2149
2150   return 0;
2151 }
2152
2153
2154 /* Match a single data transfer element.  */
2155
2156 static match
2157 match_dt_element (io_kind k, gfc_dt *dt)
2158 {
2159   char name[GFC_MAX_SYMBOL_LEN + 1];
2160   gfc_symbol *sym;
2161   match m;
2162
2163   if (gfc_match (" unit =") == MATCH_YES)
2164     {
2165       m = match_dt_unit (k, dt);
2166       if (m != MATCH_NO)
2167         return m;
2168     }
2169
2170   if (gfc_match (" fmt =") == MATCH_YES)
2171     {
2172       m = match_dt_format (dt);
2173       if (m != MATCH_NO)
2174         return m;
2175     }
2176
2177   if (gfc_match (" nml = %n", name) == MATCH_YES)
2178     {
2179       if (dt->namelist != NULL)
2180         {
2181           gfc_error ("Duplicate NML specification at %C");
2182           return MATCH_ERROR;
2183         }
2184
2185       if (gfc_find_symbol (name, NULL, 1, &sym))
2186         return MATCH_ERROR;
2187
2188       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2189         {
2190           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2191                      sym != NULL ? sym->name : name);
2192           return MATCH_ERROR;
2193         }
2194
2195       dt->namelist = sym;
2196       if (k == M_READ && check_namelist (sym))
2197         return MATCH_ERROR;
2198
2199       return MATCH_YES;
2200     }
2201
2202   m = match_etag (&tag_rec, &dt->rec);
2203   if (m != MATCH_NO)
2204     return m;
2205   m = match_etag (&tag_spos, &dt->rec);
2206   if (m != MATCH_NO)
2207     return m;
2208   m = match_out_tag (&tag_iomsg, &dt->iomsg);
2209   if (m != MATCH_NO)
2210     return m;
2211   m = match_out_tag (&tag_iostat, &dt->iostat);
2212   if (m != MATCH_NO)
2213     return m;
2214   m = match_ltag (&tag_err, &dt->err);
2215   if (m == MATCH_YES)
2216     dt->err_where = gfc_current_locus;
2217   if (m != MATCH_NO)
2218     return m;
2219   m = match_etag (&tag_advance, &dt->advance);
2220   if (m != MATCH_NO)
2221     return m;
2222   m = match_out_tag (&tag_size, &dt->size);
2223   if (m != MATCH_NO)
2224     return m;
2225
2226   m = match_ltag (&tag_end, &dt->end);
2227   if (m == MATCH_YES)
2228     {
2229       if (k == M_WRITE)
2230        {
2231          gfc_error ("END tag at %C not allowed in output statement");
2232          return MATCH_ERROR;
2233        }
2234       dt->end_where = gfc_current_locus;
2235     }
2236   if (m != MATCH_NO)
2237     return m;
2238
2239   m = match_ltag (&tag_eor, &dt->eor);
2240   if (m == MATCH_YES)
2241     dt->eor_where = gfc_current_locus;
2242   if (m != MATCH_NO)
2243     return m;
2244
2245   return MATCH_NO;
2246 }
2247
2248
2249 /* Free a data transfer structure and everything below it.  */
2250
2251 void
2252 gfc_free_dt (gfc_dt *dt)
2253 {
2254   if (dt == NULL)
2255     return;
2256
2257   gfc_free_expr (dt->io_unit);
2258   gfc_free_expr (dt->format_expr);
2259   gfc_free_expr (dt->rec);
2260   gfc_free_expr (dt->advance);
2261   gfc_free_expr (dt->iomsg);
2262   gfc_free_expr (dt->iostat);
2263   gfc_free_expr (dt->size);
2264   gfc_free (dt);
2265 }
2266
2267
2268 /* Resolve everything in a gfc_dt structure.  */
2269
2270 try
2271 gfc_resolve_dt (gfc_dt *dt)
2272 {
2273   gfc_expr *e;
2274
2275   RESOLVE_TAG (&tag_format, dt->format_expr);
2276   RESOLVE_TAG (&tag_rec, dt->rec);
2277   RESOLVE_TAG (&tag_spos, dt->rec);
2278   RESOLVE_TAG (&tag_advance, dt->advance);
2279   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2280   RESOLVE_TAG (&tag_iostat, dt->iostat);
2281   RESOLVE_TAG (&tag_size, dt->size);
2282
2283   e = dt->io_unit;
2284   if (gfc_resolve_expr (e) == SUCCESS
2285       && (e->ts.type != BT_INTEGER
2286           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2287     {
2288       gfc_error ("UNIT specification at %L must be an INTEGER expression "
2289                  "or a CHARACTER variable", &e->where);
2290       return FAILURE;
2291     }
2292
2293   if (e->ts.type == BT_CHARACTER)
2294     {
2295       if (gfc_has_vector_index (e))
2296         {
2297           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2298           return FAILURE;
2299         }
2300     }
2301
2302   if (e->rank && e->ts.type != BT_CHARACTER)
2303     {
2304       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2305       return FAILURE;
2306     }
2307
2308   if (dt->err)
2309     {
2310       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2311         return FAILURE;
2312       if (dt->err->defined == ST_LABEL_UNKNOWN)
2313         {
2314           gfc_error ("ERR tag label %d at %L not defined",
2315                       dt->err->value, &dt->err_where);
2316           return FAILURE;
2317         }
2318     }
2319
2320   if (dt->end)
2321     {
2322       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2323         return FAILURE;
2324       if (dt->end->defined == ST_LABEL_UNKNOWN)
2325         {
2326           gfc_error ("END tag label %d at %L not defined",
2327                       dt->end->value, &dt->end_where);
2328           return FAILURE;
2329         }
2330     }
2331
2332   if (dt->eor)
2333     {
2334       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2335         return FAILURE;
2336       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2337         {
2338           gfc_error ("EOR tag label %d at %L not defined",
2339                       dt->eor->value, &dt->eor_where);
2340           return FAILURE;
2341         }
2342     }
2343
2344   /* Check the format label actually exists.  */
2345   if (dt->format_label && dt->format_label != &format_asterisk
2346       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2347     {
2348       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2349                  &dt->format_label->where);
2350       return FAILURE;
2351     }
2352   return SUCCESS;
2353 }
2354
2355
2356 /* Given an io_kind, return its name.  */
2357
2358 static const char *
2359 io_kind_name (io_kind k)
2360 {
2361   const char *name;
2362
2363   switch (k)
2364     {
2365     case M_READ:
2366       name = "READ";
2367       break;
2368     case M_WRITE:
2369       name = "WRITE";
2370       break;
2371     case M_PRINT:
2372       name = "PRINT";
2373       break;
2374     case M_INQUIRE:
2375       name = "INQUIRE";
2376       break;
2377     default:
2378       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2379     }
2380
2381   return name;
2382 }
2383
2384
2385 /* Match an IO iteration statement of the form:
2386
2387    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2388
2389    which is equivalent to a single IO element.  This function is
2390    mutually recursive with match_io_element().  */
2391
2392 static match match_io_element (io_kind, gfc_code **);
2393
2394 static match
2395 match_io_iterator (io_kind k, gfc_code **result)
2396 {
2397   gfc_code *head, *tail, *new;
2398   gfc_iterator *iter;
2399   locus old_loc;
2400   match m;
2401   int n;
2402
2403   iter = NULL;
2404   head = NULL;
2405   old_loc = gfc_current_locus;
2406
2407   if (gfc_match_char ('(') != MATCH_YES)
2408     return MATCH_NO;
2409
2410   m = match_io_element (k, &head);
2411   tail = head;
2412
2413   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2414     {
2415       m = MATCH_NO;
2416       goto cleanup;
2417     }
2418
2419   /* Can't be anything but an IO iterator.  Build a list.  */
2420   iter = gfc_get_iterator ();
2421
2422   for (n = 1;; n++)
2423     {
2424       m = gfc_match_iterator (iter, 0);
2425       if (m == MATCH_ERROR)
2426         goto cleanup;
2427       if (m == MATCH_YES)
2428         {
2429           gfc_check_do_variable (iter->var->symtree);
2430           break;
2431         }
2432
2433       m = match_io_element (k, &new);
2434       if (m == MATCH_ERROR)
2435         goto cleanup;
2436       if (m == MATCH_NO)
2437         {
2438           if (n > 2)
2439             goto syntax;
2440           goto cleanup;
2441         }
2442
2443       tail = gfc_append_code (tail, new);
2444
2445       if (gfc_match_char (',') != MATCH_YES)
2446         {
2447           if (n > 2)
2448             goto syntax;
2449           m = MATCH_NO;
2450           goto cleanup;
2451         }
2452     }
2453
2454   if (gfc_match_char (')') != MATCH_YES)
2455     goto syntax;
2456
2457   new = gfc_get_code ();
2458   new->op = EXEC_DO;
2459   new->ext.iterator = iter;
2460
2461   new->block = gfc_get_code ();
2462   new->block->op = EXEC_DO;
2463   new->block->next = head;
2464
2465   *result = new;
2466   return MATCH_YES;
2467
2468 syntax:
2469   gfc_error ("Syntax error in I/O iterator at %C");
2470   m = MATCH_ERROR;
2471
2472 cleanup:
2473   gfc_free_iterator (iter, 1);
2474   gfc_free_statements (head);
2475   gfc_current_locus = old_loc;
2476   return m;
2477 }
2478
2479
2480 /* Match a single element of an IO list, which is either a single
2481    expression or an IO Iterator.  */
2482
2483 static match
2484 match_io_element (io_kind k, gfc_code **cpp)
2485 {
2486   gfc_expr *expr;
2487   gfc_code *cp;
2488   match m;
2489
2490   expr = NULL;
2491
2492   m = match_io_iterator (k, cpp);
2493   if (m == MATCH_YES)
2494     return MATCH_YES;
2495
2496   if (k == M_READ)
2497     {
2498       m = gfc_match_variable (&expr, 0);
2499       if (m == MATCH_NO)
2500         gfc_error ("Expected variable in READ statement at %C");
2501     }
2502   else
2503     {
2504       m = gfc_match_expr (&expr);
2505       if (m == MATCH_NO)
2506         gfc_error ("Expected expression in %s statement at %C",
2507                    io_kind_name (k));
2508     }
2509
2510   if (m == MATCH_YES)
2511     switch (k)
2512       {
2513       case M_READ:
2514         if (expr->symtree->n.sym->attr.intent == INTENT_IN)
2515           {
2516             gfc_error ("Variable '%s' in input list at %C cannot be "
2517                        "INTENT(IN)", expr->symtree->n.sym->name);
2518             m = MATCH_ERROR;
2519           }
2520
2521         if (gfc_pure (NULL)
2522             && gfc_impure_variable (expr->symtree->n.sym)
2523             && current_dt->io_unit->ts.type == BT_CHARACTER)
2524           {
2525             gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
2526                        expr->symtree->n.sym->name);
2527             m = MATCH_ERROR;
2528           }
2529
2530         if (gfc_check_do_variable (expr->symtree))
2531           m = MATCH_ERROR;
2532
2533         break;
2534
2535       case M_WRITE:
2536         if (current_dt->io_unit->ts.type == BT_CHARACTER
2537             && gfc_pure (NULL)
2538             && current_dt->io_unit->expr_type == EXPR_VARIABLE
2539             && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
2540           {
2541             gfc_error ("Cannot write to internal file unit '%s' at %C "
2542                        "inside a PURE procedure",
2543                        current_dt->io_unit->symtree->n.sym->name);
2544             m = MATCH_ERROR;
2545           }
2546
2547         break;
2548
2549       default:
2550         break;
2551       }
2552
2553   if (m != MATCH_YES)
2554     {
2555       gfc_free_expr (expr);
2556       return MATCH_ERROR;
2557     }
2558
2559   cp = gfc_get_code ();
2560   cp->op = EXEC_TRANSFER;
2561   cp->expr = expr;
2562
2563   *cpp = cp;
2564   return MATCH_YES;
2565 }
2566
2567
2568 /* Match an I/O list, building gfc_code structures as we go.  */
2569
2570 static match
2571 match_io_list (io_kind k, gfc_code **head_p)
2572 {
2573   gfc_code *head, *tail, *new;
2574   match m;
2575
2576   *head_p = head = tail = NULL;
2577   if (gfc_match_eos () == MATCH_YES)
2578     return MATCH_YES;
2579
2580   for (;;)
2581     {
2582       m = match_io_element (k, &new);
2583       if (m == MATCH_ERROR)
2584         goto cleanup;
2585       if (m == MATCH_NO)
2586         goto syntax;
2587
2588       tail = gfc_append_code (tail, new);
2589       if (head == NULL)
2590         head = new;
2591
2592       if (gfc_match_eos () == MATCH_YES)
2593         break;
2594       if (gfc_match_char (',') != MATCH_YES)
2595         goto syntax;
2596     }
2597
2598   *head_p = head;
2599   return MATCH_YES;
2600
2601 syntax:
2602   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2603
2604 cleanup:
2605   gfc_free_statements (head);
2606   return MATCH_ERROR;
2607 }
2608
2609
2610 /* Attach the data transfer end node.  */
2611
2612 static void
2613 terminate_io (gfc_code *io_code)
2614 {
2615   gfc_code *c;
2616
2617   if (io_code == NULL)
2618     io_code = new_st.block;
2619
2620   c = gfc_get_code ();
2621   c->op = EXEC_DT_END;
2622
2623   /* Point to structure that is already there */
2624   c->ext.dt = new_st.ext.dt;
2625   gfc_append_code (io_code, c);
2626 }
2627
2628
2629 /* Check the constraints for a data transfer statement.  The majority of the
2630    constraints appearing in 9.4 of the standard appear here.  Some are handled
2631    in resolve_tag and others in gfc_resolve_dt.  */
2632
2633 static match
2634 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
2635                       locus *spec_end)
2636 {
2637 #define io_constraint(condition,msg,arg)\
2638 if (condition) \
2639   {\
2640     gfc_error(msg,arg);\
2641     m = MATCH_ERROR;\
2642   }
2643
2644   match m;
2645   gfc_expr *expr;
2646   gfc_symbol *sym = NULL;
2647
2648   m = MATCH_YES;
2649
2650   expr = dt->io_unit;
2651   if (expr && expr->expr_type == EXPR_VARIABLE
2652       && expr->ts.type == BT_CHARACTER)
2653     {
2654       sym = expr->symtree->n.sym;
2655
2656       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
2657                      "Internal file at %L must not be INTENT(IN)",
2658                      &expr->where);
2659
2660       io_constraint (gfc_has_vector_index (dt->io_unit),
2661                      "Internal file incompatible with vector subscript at %L",
2662                      &expr->where);
2663
2664       io_constraint (dt->rec != NULL,
2665                      "REC tag at %L is incompatible with internal file",
2666                      &dt->rec->where);
2667
2668       if (dt->namelist != NULL)
2669         {
2670           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
2671                               "at %L with namelist", &expr->where)
2672               == FAILURE)
2673             m = MATCH_ERROR;
2674         }
2675
2676       io_constraint (dt->advance != NULL,
2677                      "ADVANCE tag at %L is incompatible with internal file",
2678                      &dt->advance->where);
2679     }
2680
2681   if (expr && expr->ts.type != BT_CHARACTER)
2682     {
2683
2684       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
2685                      "IO UNIT in %s statement at %C must be "
2686                      "an internal file in a PURE procedure",
2687                      io_kind_name (k));
2688     }
2689
2690
2691   if (k != M_READ)
2692     {
2693       io_constraint (dt->end, "END tag not allowed with output at %L",
2694                      &dt->end_where);
2695
2696       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
2697                      &dt->eor_where);
2698
2699       io_constraint (k != M_READ && dt->size,
2700                      "SIZE=specifier not allowed with output at %L",
2701                      &dt->size->where);
2702     }
2703   else
2704     {
2705       io_constraint (dt->size && dt->advance == NULL,
2706                      "SIZE tag at %L requires an ADVANCE tag",
2707                      &dt->size->where);
2708
2709       io_constraint (dt->eor && dt->advance == NULL,
2710                      "EOR tag at %L requires an ADVANCE tag",
2711                      &dt->eor_where);
2712     }
2713
2714
2715
2716   if (dt->namelist)
2717     {
2718       io_constraint (io_code && dt->namelist,
2719                      "NAMELIST cannot be followed by IO-list at %L",
2720                      &io_code->loc);
2721
2722       io_constraint (dt->format_expr,
2723                      "IO spec-list cannot contain both NAMELIST group name "
2724                      "and format specification at %L.",
2725                      &dt->format_expr->where);
2726
2727       io_constraint (dt->format_label,
2728                      "IO spec-list cannot contain both NAMELIST group name "
2729                      "and format label at %L", spec_end);
2730
2731       io_constraint (dt->rec,
2732                      "NAMELIST IO is not allowed with a REC=specifier "
2733                      "at %L.", &dt->rec->where);
2734
2735       io_constraint (dt->advance,
2736                      "NAMELIST IO is not allowed with a ADVANCE=specifier "
2737                      "at %L.", &dt->advance->where);
2738     }
2739
2740   if (dt->rec)
2741     {
2742       io_constraint (dt->end,
2743                      "An END tag is not allowed with a "
2744                      "REC=specifier at %L.", &dt->end_where);
2745
2746
2747       io_constraint (dt->format_label == &format_asterisk,
2748                      "FMT=* is not allowed with a REC=specifier "
2749                      "at %L.", spec_end);
2750     }
2751
2752   if (dt->advance)
2753     {
2754       int not_yes, not_no;
2755       expr = dt->advance;
2756
2757       io_constraint (dt->format_label == &format_asterisk,
2758                      "List directed format(*) is not allowed with a "
2759                      "ADVANCE=specifier at %L.", &expr->where);
2760
2761       io_constraint (dt->format_expr == NULL && dt->format_label == NULL
2762                      && dt->namelist == NULL,
2763                      "the ADVANCE=specifier at %L must appear with an "
2764                      "explicit format expression", &expr->where);
2765
2766       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
2767         {
2768           const char * advance = expr->value.character.string;
2769           not_no = strcasecmp (advance, "no") != 0;
2770           not_yes = strcasecmp (advance, "yes") != 0;
2771         }
2772       else
2773         {
2774           not_no = 0;
2775           not_yes = 0;
2776         }
2777
2778       io_constraint (not_no && not_yes,
2779                      "ADVANCE=specifier at %L must have value = "
2780                      "YES or NO.", &expr->where);
2781
2782       io_constraint (dt->size && not_no && k == M_READ,
2783                      "SIZE tag at %L requires an ADVANCE = 'NO'",
2784                      &dt->size->where);
2785
2786       io_constraint (dt->eor && not_no && k == M_READ,
2787                      "EOR tag at %L requires an ADVANCE = 'NO'",
2788                      &dt->eor_where);
2789     }
2790
2791   expr = dt->format_expr;
2792   if (gfc_simplify_expr (expr, 0) == FAILURE
2793       || check_format_string (expr, k == M_READ) == FAILURE)
2794     return MATCH_ERROR;
2795
2796   return m;
2797 }
2798 #undef io_constraint
2799
2800
2801 /* Match a READ, WRITE or PRINT statement.  */
2802
2803 static match
2804 match_io (io_kind k)
2805 {
2806   char name[GFC_MAX_SYMBOL_LEN + 1];
2807   gfc_code *io_code;
2808   gfc_symbol *sym;
2809   int comma_flag, c;
2810   locus where;
2811   locus spec_end;
2812   gfc_dt *dt;
2813   match m;
2814
2815   where = gfc_current_locus;
2816   comma_flag = 0;
2817   current_dt = dt = gfc_getmem (sizeof (gfc_dt));
2818   m = gfc_match_char ('(');
2819   if (m == MATCH_NO)
2820     {
2821       where = gfc_current_locus;
2822       if (k == M_WRITE)
2823         goto syntax;
2824       else if (k == M_PRINT)
2825         {
2826           /* Treat the non-standard case of PRINT namelist.  */
2827           if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
2828               && gfc_match_name (name) == MATCH_YES)
2829             {
2830               gfc_find_symbol (name, NULL, 1, &sym);
2831               if (sym && sym->attr.flavor == FL_NAMELIST)
2832                 {
2833                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
2834                                       "%C is an extension") == FAILURE)
2835                     {
2836                       m = MATCH_ERROR;
2837                       goto cleanup;
2838                     }
2839
2840                   dt->io_unit = default_unit (k);
2841                   dt->namelist = sym;
2842                   goto get_io_list;
2843                 }
2844               else
2845                 gfc_current_locus = where;
2846             }
2847         }
2848
2849       if (gfc_current_form == FORM_FREE)
2850         {
2851           c = gfc_peek_char();
2852           if (c != ' ' && c != '*' && c != '\'' && c != '"')
2853             {
2854               m = MATCH_NO;
2855               goto cleanup;
2856             }
2857         }
2858
2859       m = match_dt_format (dt);
2860       if (m == MATCH_ERROR)
2861         goto cleanup;
2862       if (m == MATCH_NO)
2863         goto syntax;
2864
2865       comma_flag = 1;
2866       dt->io_unit = default_unit (k);
2867       goto get_io_list;
2868     }
2869   else
2870     {
2871       /* Before issuing an error for a malformed 'print (1,*)' type of
2872          error, check for a default-char-expr of the form ('(I0)').  */
2873       if (k == M_PRINT && m == MATCH_YES)
2874         {
2875           /* Reset current locus to get the initial '(' in an expression.  */
2876           gfc_current_locus = where;
2877           dt->format_expr = NULL;
2878           m = match_dt_format (dt);
2879
2880           if (m == MATCH_ERROR)
2881             goto cleanup;
2882           if (m == MATCH_NO || dt->format_expr == NULL)
2883             goto syntax;
2884
2885           comma_flag = 1;
2886           dt->io_unit = default_unit (k);
2887           goto get_io_list;
2888         }
2889     }
2890
2891   /* Match a control list */
2892   if (match_dt_element (k, dt) == MATCH_YES)
2893     goto next;
2894   if (match_dt_unit (k, dt) != MATCH_YES)
2895     goto loop;
2896
2897   if (gfc_match_char (')') == MATCH_YES)
2898     goto get_io_list;
2899   if (gfc_match_char (',') != MATCH_YES)
2900     goto syntax;
2901
2902   m = match_dt_element (k, dt);
2903   if (m == MATCH_YES)
2904     goto next;
2905   if (m == MATCH_ERROR)
2906     goto cleanup;
2907
2908   m = match_dt_format (dt);
2909   if (m == MATCH_YES)
2910     goto next;
2911   if (m == MATCH_ERROR)
2912     goto cleanup;
2913
2914   where = gfc_current_locus;
2915
2916   m = gfc_match_name (name);
2917   if (m == MATCH_YES)
2918     {
2919       gfc_find_symbol (name, NULL, 1, &sym);
2920       if (sym && sym->attr.flavor == FL_NAMELIST)
2921         {
2922           dt->namelist = sym;
2923           if (k == M_READ && check_namelist (sym))
2924             {
2925               m = MATCH_ERROR;
2926               goto cleanup;
2927             }
2928           goto next;
2929         }
2930     }
2931
2932   gfc_current_locus = where;
2933
2934   goto loop;                    /* No matches, try regular elements */
2935
2936 next:
2937   if (gfc_match_char (')') == MATCH_YES)
2938     goto get_io_list;
2939   if (gfc_match_char (',') != MATCH_YES)
2940     goto syntax;
2941
2942 loop:
2943   for (;;)
2944     {
2945       m = match_dt_element (k, dt);
2946       if (m == MATCH_NO)
2947         goto syntax;
2948       if (m == MATCH_ERROR)
2949         goto cleanup;
2950
2951       if (gfc_match_char (')') == MATCH_YES)
2952         break;
2953       if (gfc_match_char (',') != MATCH_YES)
2954         goto syntax;
2955     }
2956
2957 get_io_list:
2958
2959   /* Used in check_io_constraints, where no locus is available.  */
2960   spec_end = gfc_current_locus;
2961
2962   /* Optional leading comma (non-standard).  */
2963   if (!comma_flag
2964       && gfc_match_char (',') == MATCH_YES
2965       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2966                          "item list at %C") == FAILURE)
2967     return MATCH_ERROR;
2968
2969   io_code = NULL;
2970   if (gfc_match_eos () != MATCH_YES)
2971     {
2972       if (comma_flag && gfc_match_char (',') != MATCH_YES)
2973         {
2974           gfc_error ("Expected comma in I/O list at %C");
2975           m = MATCH_ERROR;
2976           goto cleanup;
2977         }
2978
2979       m = match_io_list (k, &io_code);
2980       if (m == MATCH_ERROR)
2981         goto cleanup;
2982       if (m == MATCH_NO)
2983         goto syntax;
2984     }
2985
2986   /* A full IO statement has been matched.  Check the constraints.  spec_end is
2987      supplied for cases where no locus is supplied.  */
2988   m = check_io_constraints (k, dt, io_code, &spec_end);
2989
2990   if (m == MATCH_ERROR)
2991     goto cleanup;
2992
2993   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
2994   new_st.ext.dt = dt;
2995   new_st.block = gfc_get_code ();
2996   new_st.block->op = new_st.op;
2997   new_st.block->next = io_code;
2998
2999   terminate_io (io_code);
3000
3001   return MATCH_YES;
3002
3003 syntax:
3004   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3005   m = MATCH_ERROR;
3006
3007 cleanup:
3008   gfc_free_dt (dt);
3009   return m;
3010 }
3011
3012
3013 match
3014 gfc_match_read (void)
3015 {
3016   return match_io (M_READ);
3017 }
3018
3019 match
3020 gfc_match_write (void)
3021 {
3022   return match_io (M_WRITE);
3023 }
3024
3025 match
3026 gfc_match_print (void)
3027 {
3028   match m;
3029
3030   m = match_io (M_PRINT);
3031   if (m != MATCH_YES)
3032     return m;
3033
3034   if (gfc_pure (NULL))
3035     {
3036       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3037       return MATCH_ERROR;
3038     }
3039
3040   return MATCH_YES;
3041 }
3042
3043
3044 /* Free a gfc_inquire structure.  */
3045
3046 void
3047 gfc_free_inquire (gfc_inquire *inquire)
3048 {
3049
3050   if (inquire == NULL)
3051     return;
3052
3053   gfc_free_expr (inquire->unit);
3054   gfc_free_expr (inquire->file);
3055   gfc_free_expr (inquire->iomsg);
3056   gfc_free_expr (inquire->iostat);
3057   gfc_free_expr (inquire->exist);
3058   gfc_free_expr (inquire->opened);
3059   gfc_free_expr (inquire->number);
3060   gfc_free_expr (inquire->named);
3061   gfc_free_expr (inquire->name);
3062   gfc_free_expr (inquire->access);
3063   gfc_free_expr (inquire->sequential);
3064   gfc_free_expr (inquire->direct);
3065   gfc_free_expr (inquire->form);
3066   gfc_free_expr (inquire->formatted);
3067   gfc_free_expr (inquire->unformatted);
3068   gfc_free_expr (inquire->recl);
3069   gfc_free_expr (inquire->nextrec);
3070   gfc_free_expr (inquire->blank);
3071   gfc_free_expr (inquire->position);
3072   gfc_free_expr (inquire->action);
3073   gfc_free_expr (inquire->read);
3074   gfc_free_expr (inquire->write);
3075   gfc_free_expr (inquire->readwrite);
3076   gfc_free_expr (inquire->delim);
3077   gfc_free_expr (inquire->pad);
3078   gfc_free_expr (inquire->iolength);
3079   gfc_free_expr (inquire->convert);
3080   gfc_free_expr (inquire->strm_pos);
3081   gfc_free (inquire);
3082 }
3083
3084
3085 /* Match an element of an INQUIRE statement.  */
3086
3087 #define RETM   if (m != MATCH_NO) return m;
3088
3089 static match
3090 match_inquire_element (gfc_inquire *inquire)
3091 {
3092   match m;
3093
3094   m = match_etag (&tag_unit, &inquire->unit);
3095   RETM m = match_etag (&tag_file, &inquire->file);
3096   RETM m = match_ltag (&tag_err, &inquire->err);
3097   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3098   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3099   RETM m = match_vtag (&tag_exist, &inquire->exist);
3100   RETM m = match_vtag (&tag_opened, &inquire->opened);
3101   RETM m = match_vtag (&tag_named, &inquire->named);
3102   RETM m = match_vtag (&tag_name, &inquire->name);
3103   RETM m = match_out_tag (&tag_number, &inquire->number);
3104   RETM m = match_vtag (&tag_s_access, &inquire->access);
3105   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3106   RETM m = match_vtag (&tag_direct, &inquire->direct);
3107   RETM m = match_vtag (&tag_s_form, &inquire->form);
3108   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3109   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3110   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3111   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3112   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3113   RETM m = match_vtag (&tag_s_position, &inquire->position);
3114   RETM m = match_vtag (&tag_s_action, &inquire->action);
3115   RETM m = match_vtag (&tag_read, &inquire->read);
3116   RETM m = match_vtag (&tag_write, &inquire->write);
3117   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3118   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3119   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3120   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3121   RETM m = match_vtag (&tag_convert, &inquire->convert);
3122   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3123   RETM return MATCH_NO;
3124 }
3125
3126 #undef RETM
3127
3128
3129 match
3130 gfc_match_inquire (void)
3131 {
3132   gfc_inquire *inquire;
3133   gfc_code *code;
3134   match m;
3135   locus loc;
3136
3137   m = gfc_match_char ('(');
3138   if (m == MATCH_NO)
3139     return m;
3140
3141   inquire = gfc_getmem (sizeof (gfc_inquire));
3142
3143   loc = gfc_current_locus;
3144
3145   m = match_inquire_element (inquire);
3146   if (m == MATCH_ERROR)
3147     goto cleanup;
3148   if (m == MATCH_NO)
3149     {
3150       m = gfc_match_expr (&inquire->unit);
3151       if (m == MATCH_ERROR)
3152         goto cleanup;
3153       if (m == MATCH_NO)
3154         goto syntax;
3155     }
3156
3157   /* See if we have the IOLENGTH form of the inquire statement.  */
3158   if (inquire->iolength != NULL)
3159     {
3160       if (gfc_match_char (')') != MATCH_YES)
3161         goto syntax;
3162
3163       m = match_io_list (M_INQUIRE, &code);
3164       if (m == MATCH_ERROR)
3165         goto cleanup;
3166       if (m == MATCH_NO)
3167         goto syntax;
3168
3169       new_st.op = EXEC_IOLENGTH;
3170       new_st.expr = inquire->iolength;
3171       new_st.ext.inquire = inquire;
3172
3173       if (gfc_pure (NULL))
3174         {
3175           gfc_free_statements (code);
3176           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3177           return MATCH_ERROR;
3178         }
3179
3180       new_st.block = gfc_get_code ();
3181       new_st.block->op = EXEC_IOLENGTH;
3182       terminate_io (code);
3183       new_st.block->next = code;
3184       return MATCH_YES;
3185     }
3186
3187   /* At this point, we have the non-IOLENGTH inquire statement.  */
3188   for (;;)
3189     {
3190       if (gfc_match_char (')') == MATCH_YES)
3191         break;
3192       if (gfc_match_char (',') != MATCH_YES)
3193         goto syntax;
3194
3195       m = match_inquire_element (inquire);
3196       if (m == MATCH_ERROR)
3197         goto cleanup;
3198       if (m == MATCH_NO)
3199         goto syntax;
3200
3201       if (inquire->iolength != NULL)
3202         {
3203           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3204           goto cleanup;
3205         }
3206     }
3207
3208   if (gfc_match_eos () != MATCH_YES)
3209     goto syntax;
3210
3211   if (inquire->unit != NULL && inquire->file != NULL)
3212     {
3213       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3214                  "UNIT specifiers", &loc);
3215       goto cleanup;
3216     }
3217
3218   if (inquire->unit == NULL && inquire->file == NULL)
3219     {
3220       gfc_error ("INQUIRE statement at %L requires either FILE or "
3221                  "UNIT specifier", &loc);
3222       goto cleanup;
3223     }
3224
3225   if (gfc_pure (NULL))
3226     {
3227       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3228       goto cleanup;
3229     }
3230
3231   new_st.op = EXEC_INQUIRE;
3232   new_st.ext.inquire = inquire;
3233   return MATCH_YES;
3234
3235 syntax:
3236   gfc_syntax_error (ST_INQUIRE);
3237
3238 cleanup:
3239   gfc_free_inquire (inquire);
3240   return MATCH_ERROR;
3241 }
3242
3243
3244 /* Resolve everything in a gfc_inquire structure.  */
3245
3246 try
3247 gfc_resolve_inquire (gfc_inquire *inquire)
3248 {
3249   RESOLVE_TAG (&tag_unit, inquire->unit);
3250   RESOLVE_TAG (&tag_file, inquire->file);
3251   RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
3252   RESOLVE_TAG (&tag_iostat, inquire->iostat);
3253   RESOLVE_TAG (&tag_exist, inquire->exist);
3254   RESOLVE_TAG (&tag_opened, inquire->opened);
3255   RESOLVE_TAG (&tag_number, inquire->number);
3256   RESOLVE_TAG (&tag_named, inquire->named);
3257   RESOLVE_TAG (&tag_name, inquire->name);
3258   RESOLVE_TAG (&tag_s_access, inquire->access);
3259   RESOLVE_TAG (&tag_sequential, inquire->sequential);
3260   RESOLVE_TAG (&tag_direct, inquire->direct);
3261   RESOLVE_TAG (&tag_s_form, inquire->form);
3262   RESOLVE_TAG (&tag_formatted, inquire->formatted);
3263   RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
3264   RESOLVE_TAG (&tag_s_recl, inquire->recl);
3265   RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
3266   RESOLVE_TAG (&tag_s_blank, inquire->blank);
3267   RESOLVE_TAG (&tag_s_position, inquire->position);
3268   RESOLVE_TAG (&tag_s_action, inquire->action);
3269   RESOLVE_TAG (&tag_read, inquire->read);
3270   RESOLVE_TAG (&tag_write, inquire->write);
3271   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
3272   RESOLVE_TAG (&tag_s_delim, inquire->delim);
3273   RESOLVE_TAG (&tag_s_pad, inquire->pad);
3274   RESOLVE_TAG (&tag_iolength, inquire->iolength);
3275   RESOLVE_TAG (&tag_convert, inquire->convert);
3276   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
3277
3278   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
3279     return FAILURE;
3280
3281   return SUCCESS;
3282 }