gcc/fortran/io.c

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