gcc/fortran/io.c

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