gcc/fortran/io.c

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