gcc/fortran/io.c

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