gcc/fortran/io.c

   1 /* Deal with I/O statements & related stuff.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "flags.h"
  25 #include "gfortran.h"
  26 #include "match.h"
  27 #include "parse.h"
  28
  29 gfc_st_label
  30 format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
  31                    0, {NULL, NULL}};
  32
  33 typedef struct
  34 {
  35   const char *name, *spec, *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->symtree == NULL || e->symtree->n.sym->as == NULL
1238       || e->symtree->n.sym->as->rank == 0)
1239     {
1240       if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1241         {
1242           gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1243                      &e->where);
1244           return FAILURE;
1245         }
1246       else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1247         {
1248           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1249                               "variable in FORMAT tag at %L", &e->where)
1250               == FAILURE)
1251             return FAILURE;
1252           if (e->symtree->n.sym->attr.assign != 1)
1253             {
1254               gfc_error ("Variable '%s' at %L has not been assigned a "
1255                          "format label", e->symtree->n.sym->name, &e->where);
1256               return FAILURE;
1257             }
1258         }
1259       else if (e->ts.type == BT_INTEGER)
1260         {
1261           gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1262                      "variable", gfc_basic_typename (e->ts.type), &e->where);
1263           return FAILURE;
1264         }
1265
1266       return SUCCESS;
1267     }
1268
1269   /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU
1270      and other type under GFC_STD_LEGACY. It may be assigned an Hollerith
1271      constant.  */
1272   if (e->ts.type == BT_CHARACTER)
1273     {
1274       if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
1275                           "in FORMAT tag at %L", &e->where) == FAILURE)
1276         return FAILURE;
1277     }
1278   else
1279     {
1280       if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1281                           "in FORMAT tag at %L", &e->where) == FAILURE)
1282         return FAILURE;
1283     }
1284
1285   return SUCCESS;
1286 }
1287
1288
1289 /* Do expression resolution and type-checking on an expression tag.  */
1290
1291 static gfc_try
1292 resolve_tag (const io_tag *tag, gfc_expr *e)
1293 {
1294   if (e == NULL)
1295     return SUCCESS;
1296
1297   if (gfc_resolve_expr (e) == FAILURE)
1298     return FAILURE;
1299
1300   if (tag == &tag_format)
1301     return resolve_tag_format (e);
1302
1303   if (e->ts.type != tag->type)
1304     {
1305       gfc_error ("%s tag at %L must be of type %s", tag->name,
1306                  &e->where, gfc_basic_typename (tag->type));
1307       return FAILURE;
1308     }
1309
1310   if (e->rank != 0)
1311     {
1312       gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1313       return FAILURE;
1314     }
1315
1316   if (tag == &tag_iomsg)
1317     {
1318       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1319                           &e->where) == FAILURE)
1320         return FAILURE;
1321     }
1322
1323   if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1324       && e->ts.kind != gfc_default_integer_kind)
1325     {
1326       if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1327                           "INTEGER in %s tag at %L", tag->name, &e->where)
1328           == FAILURE)
1329         return FAILURE;
1330     }
1331
1332   if (tag == &tag_convert)
1333     {
1334       if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1335                           &e->where) == FAILURE)
1336         return FAILURE;
1337     }
1338
1339   return SUCCESS;
1340 }
1341
1342
1343 /* Match a single tag of an OPEN statement.  */
1344
1345 static match
1346 match_open_element (gfc_open *open)
1347 {
1348   match m;
1349
1350   m = match_etag (&tag_e_async, &open->asynchronous);
1351   if (m != MATCH_NO)
1352     return m;
1353   m = match_etag (&tag_unit, &open->unit);
1354   if (m != MATCH_NO)
1355     return m;
1356   m = match_out_tag (&tag_iomsg, &open->iomsg);
1357   if (m != MATCH_NO)
1358     return m;
1359   m = match_out_tag (&tag_iostat, &open->iostat);
1360   if (m != MATCH_NO)
1361     return m;
1362   m = match_etag (&tag_file, &open->file);
1363   if (m != MATCH_NO)
1364     return m;
1365   m = match_etag (&tag_status, &open->status);
1366   if (m != MATCH_NO)
1367     return m;
1368   m = match_etag (&tag_e_access, &open->access);
1369   if (m != MATCH_NO)
1370     return m;
1371   m = match_etag (&tag_e_form, &open->form);
1372   if (m != MATCH_NO)
1373     return m;
1374   m = match_etag (&tag_e_recl, &open->recl);
1375   if (m != MATCH_NO)
1376     return m;
1377   m = match_etag (&tag_e_blank, &open->blank);
1378   if (m != MATCH_NO)
1379     return m;
1380   m = match_etag (&tag_e_position, &open->position);
1381   if (m != MATCH_NO)
1382     return m;
1383   m = match_etag (&tag_e_action, &open->action);
1384   if (m != MATCH_NO)
1385     return m;
1386   m = match_etag (&tag_e_delim, &open->delim);
1387   if (m != MATCH_NO)
1388     return m;
1389   m = match_etag (&tag_e_pad, &open->pad);
1390   if (m != MATCH_NO)
1391     return m;
1392   m = match_etag (&tag_e_decimal, &open->decimal);
1393   if (m != MATCH_NO)
1394     return m;
1395   m = match_etag (&tag_e_encoding, &open->encoding);
1396   if (m != MATCH_NO)
1397     return m;
1398   m = match_etag (&tag_e_round, &open->round);
1399   if (m != MATCH_NO)
1400     return m;
1401   m = match_etag (&tag_e_sign, &open->sign);
1402   if (m != MATCH_NO)
1403     return m;
1404   m = match_ltag (&tag_err, &open->err);
1405   if (m != MATCH_NO)
1406     return m;
1407   m = match_etag (&tag_convert, &open->convert);
1408   if (m != MATCH_NO)
1409     return m;
1410
1411   return MATCH_NO;
1412 }
1413
1414
1415 /* Free the gfc_open structure and all the expressions it contains.  */
1416
1417 void
1418 gfc_free_open (gfc_open *open)
1419 {
1420   if (open == NULL)
1421     return;
1422
1423   gfc_free_expr (open->unit);
1424   gfc_free_expr (open->iomsg);
1425   gfc_free_expr (open->iostat);
1426   gfc_free_expr (open->file);
1427   gfc_free_expr (open->status);
1428   gfc_free_expr (open->access);
1429   gfc_free_expr (open->form);
1430   gfc_free_expr (open->recl);
1431   gfc_free_expr (open->blank);
1432   gfc_free_expr (open->position);
1433   gfc_free_expr (open->action);
1434   gfc_free_expr (open->delim);
1435   gfc_free_expr (open->pad);
1436   gfc_free_expr (open->decimal);
1437   gfc_free_expr (open->encoding);
1438   gfc_free_expr (open->round);
1439   gfc_free_expr (open->sign);
1440   gfc_free_expr (open->convert);
1441   gfc_free_expr (open->asynchronous);
1442   gfc_free (open);
1443 }
1444
1445
1446 /* Resolve everything in a gfc_open structure.  */
1447
1448 gfc_try
1449 gfc_resolve_open (gfc_open *open)
1450 {
1451
1452   RESOLVE_TAG (&tag_unit, open->unit);
1453   RESOLVE_TAG (&tag_iomsg, open->iomsg);
1454   RESOLVE_TAG (&tag_iostat, open->iostat);
1455   RESOLVE_TAG (&tag_file, open->file);
1456   RESOLVE_TAG (&tag_status, open->status);
1457   RESOLVE_TAG (&tag_e_access, open->access);
1458   RESOLVE_TAG (&tag_e_form, open->form);
1459   RESOLVE_TAG (&tag_e_recl, open->recl);
1460   RESOLVE_TAG (&tag_e_blank, open->blank);
1461   RESOLVE_TAG (&tag_e_position, open->position);
1462   RESOLVE_TAG (&tag_e_action, open->action);
1463   RESOLVE_TAG (&tag_e_delim, open->delim);
1464   RESOLVE_TAG (&tag_e_pad, open->pad);
1465   RESOLVE_TAG (&tag_e_decimal, open->decimal);
1466   RESOLVE_TAG (&tag_e_encoding, open->encoding);
1467   RESOLVE_TAG (&tag_e_async, open->asynchronous);
1468   RESOLVE_TAG (&tag_e_round, open->round);
1469   RESOLVE_TAG (&tag_e_sign, open->sign);
1470   RESOLVE_TAG (&tag_convert, open->convert);
1471
1472   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1473     return FAILURE;
1474
1475   return SUCCESS;
1476 }
1477
1478
1479 /* Check if a given value for a SPECIFIER is either in the list of values
1480    allowed in F95 or F2003, issuing an error message and returning a zero
1481    value if it is not allowed.  */
1482
1483 static int
1484 compare_to_allowed_values (const char *specifier, const char *allowed[],
1485                            const char *allowed_f2003[],
1486                            const char *allowed_gnu[], gfc_char_t *value,
1487                            const char *statement, bool warn)
1488 {
1489   int i;
1490   unsigned int len;
1491
1492   len = gfc_wide_strlen (value);
1493   if (len > 0)
1494   {
1495     for (len--; len > 0; len--)
1496       if (value[len] != ' ')
1497         break;
1498     len++;
1499   }
1500
1501   for (i = 0; allowed[i]; i++)
1502     if (len == strlen (allowed[i])
1503         && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1504       return 1;
1505
1506   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1507     if (len == strlen (allowed_f2003[i])
1508         && gfc_wide_strncasecmp (value, allowed_f2003[i],
1509                                  strlen (allowed_f2003[i])) == 0)
1510       {
1511         notification n = gfc_notification_std (GFC_STD_F2003);
1512
1513         if (n == WARNING || (warn && n == ERROR))
1514           {
1515             gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1516                          "has value '%s'", specifier, statement,
1517                          allowed_f2003[i]);
1518             return 1;
1519           }
1520         else
1521           if (n == ERROR)
1522             {
1523               gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1524                               "%s statement at %C has value '%s'", specifier,
1525                               statement, allowed_f2003[i]);
1526               return 0;
1527             }
1528
1529         /* n == SILENT */
1530         return 1;
1531       }
1532
1533   for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1534     if (len == strlen (allowed_gnu[i])
1535         && gfc_wide_strncasecmp (value, allowed_gnu[i],
1536                                  strlen (allowed_gnu[i])) == 0)
1537       {
1538         notification n = gfc_notification_std (GFC_STD_GNU);
1539
1540         if (n == WARNING || (warn && n == ERROR))
1541           {
1542             gfc_warning ("Extension: %s specifier in %s statement at %C "
1543                          "has value '%s'", specifier, statement,
1544                          allowed_gnu[i]);
1545             return 1;
1546           }
1547         else
1548           if (n == ERROR)
1549             {
1550               gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1551                               "%s statement at %C has value '%s'", specifier,
1552                               statement, allowed_gnu[i]);
1553               return 0;
1554             }
1555
1556         /* n == SILENT */
1557         return 1;
1558       }
1559
1560   if (warn)
1561     {
1562       char *s = gfc_widechar_to_char (value, -1);
1563       gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1564                    specifier, statement, s);
1565       gfc_free (s);
1566       return 1;
1567     }
1568   else
1569     {
1570       char *s = gfc_widechar_to_char (value, -1);
1571       gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1572                  specifier, statement, s);
1573       gfc_free (s);
1574       return 0;
1575     }
1576 }
1577
1578
1579 /* Match an OPEN statement.  */
1580
1581 match
1582 gfc_match_open (void)
1583 {
1584   gfc_open *open;
1585   match m;
1586   bool warn;
1587
1588   m = gfc_match_char ('(');
1589   if (m == MATCH_NO)
1590     return m;
1591
1592   open = XCNEW (gfc_open);
1593
1594   m = match_open_element (open);
1595
1596   if (m == MATCH_ERROR)
1597     goto cleanup;
1598   if (m == MATCH_NO)
1599     {
1600       m = gfc_match_expr (&open->unit);
1601       if (m == MATCH_NO)
1602         goto syntax;
1603       if (m == MATCH_ERROR)
1604         goto cleanup;
1605     }
1606
1607   for (;;)
1608     {
1609       if (gfc_match_char (')') == MATCH_YES)
1610         break;
1611       if (gfc_match_char (',') != MATCH_YES)
1612         goto syntax;
1613
1614       m = match_open_element (open);
1615       if (m == MATCH_ERROR)
1616         goto cleanup;
1617       if (m == MATCH_NO)
1618         goto syntax;
1619     }
1620
1621   if (gfc_match_eos () == MATCH_NO)
1622     goto syntax;
1623
1624   if (gfc_pure (NULL))
1625     {
1626       gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1627       goto cleanup;
1628     }
1629
1630   warn = (open->err || open->iostat) ? true : false;
1631   /* Checks on the ACCESS specifier.  */
1632   if (open->access && open->access->expr_type == EXPR_CONSTANT)
1633     {
1634       static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1635       static const char *access_f2003[] = { "STREAM", NULL };
1636       static const char *access_gnu[] = { "APPEND", NULL };
1637
1638       if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1639                                       access_gnu,
1640                                       open->access->value.character.string,
1641                                       "OPEN", warn))
1642         goto cleanup;
1643     }
1644
1645   /* Checks on the ACTION specifier.  */
1646   if (open->action && open->action->expr_type == EXPR_CONSTANT)
1647     {
1648       static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1649
1650       if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1651                                       open->action->value.character.string,
1652                                       "OPEN", warn))
1653         goto cleanup;
1654     }
1655
1656   /* Checks on the ASYNCHRONOUS specifier.  */
1657   if (open->asynchronous)
1658     {
1659       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
1660           "not allowed in Fortran 95") == FAILURE)
1661         goto cleanup;
1662
1663       if (open->asynchronous->expr_type == EXPR_CONSTANT)
1664         {
1665           static const char * asynchronous[] = { "YES", "NO", NULL };
1666
1667           if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1668                         NULL, NULL, open->asynchronous->value.character.string,
1669                         "OPEN", warn))
1670             goto cleanup;
1671         }
1672     }
1673
1674   /* Checks on the BLANK specifier.  */
1675   if (open->blank)
1676     {
1677       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
1678           "not allowed in Fortran 95") == FAILURE)
1679         goto cleanup;
1680
1681       if (open->blank->expr_type == EXPR_CONSTANT)
1682         {
1683           static const char *blank[] = { "ZERO", "NULL", NULL };
1684
1685           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1686                                           open->blank->value.character.string,
1687                                           "OPEN", warn))
1688             goto cleanup;
1689         }
1690     }
1691
1692   /* Checks on the DECIMAL specifier.  */
1693   if (open->decimal)
1694     {
1695       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
1696           "not allowed in Fortran 95") == FAILURE)
1697         goto cleanup;
1698
1699       if (open->decimal->expr_type == EXPR_CONSTANT)
1700         {
1701           static const char * decimal[] = { "COMMA", "POINT", NULL };
1702
1703           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1704                                           open->decimal->value.character.string,
1705                                           "OPEN", warn))
1706             goto cleanup;
1707         }
1708     }
1709
1710   /* Checks on the DELIM specifier.  */
1711   if (open->delim)
1712     {
1713       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1714           "not allowed in Fortran 95") == FAILURE)
1715         goto cleanup;
1716
1717       if (open->delim->expr_type == EXPR_CONSTANT)
1718         {
1719           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1720
1721           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1722                                           open->delim->value.character.string,
1723                                           "OPEN", warn))
1724           goto cleanup;
1725         }
1726     }
1727
1728   /* Checks on the ENCODING specifier.  */
1729   if (open->encoding)
1730     {
1731       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1732           "not allowed in Fortran 95") == FAILURE)
1733         goto cleanup;
1734
1735       if (open->encoding->expr_type == EXPR_CONSTANT)
1736         {
1737           static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1738
1739           if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1740                                           open->encoding->value.character.string,
1741                                           "OPEN", warn))
1742           goto cleanup;
1743         }
1744     }
1745
1746   /* Checks on the FORM specifier.  */
1747   if (open->form && open->form->expr_type == EXPR_CONSTANT)
1748     {
1749       static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1750
1751       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1752                                       open->form->value.character.string,
1753                                       "OPEN", warn))
1754         goto cleanup;
1755     }
1756
1757   /* Checks on the PAD specifier.  */
1758   if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1759     {
1760       static const char *pad[] = { "YES", "NO", NULL };
1761
1762       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1763                                       open->pad->value.character.string,
1764                                       "OPEN", warn))
1765         goto cleanup;
1766     }
1767
1768   /* Checks on the POSITION specifier.  */
1769   if (open->position && open->position->expr_type == EXPR_CONSTANT)
1770     {
1771       static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
1772
1773       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
1774                                       open->position->value.character.string,
1775                                       "OPEN", warn))
1776         goto cleanup;
1777     }
1778
1779   /* Checks on the ROUND specifier.  */
1780   if (open->round)
1781     {
1782       /* When implemented, change the following to use gfc_notify_std F2003.  */
1783       gfc_error ("Fortran F2003: ROUND= specifier at %C not implemented");
1784       goto cleanup;
1785
1786       if (open->round->expr_type == EXPR_CONSTANT)
1787         {
1788           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
1789                                           "COMPATIBLE", "PROCESSOR_DEFINED",
1790                                            NULL };
1791
1792           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
1793                                           open->round->value.character.string,
1794                                           "OPEN", warn))
1795           goto cleanup;
1796         }
1797     }
1798
1799   /* Checks on the SIGN specifier.  */
1800   if (open->sign)
1801     {
1802       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
1803           "not allowed in Fortran 95") == FAILURE)
1804         goto cleanup;
1805
1806       if (open->sign->expr_type == EXPR_CONSTANT)
1807         {
1808           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
1809                                           NULL };
1810
1811           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
1812                                           open->sign->value.character.string,
1813                                           "OPEN", warn))
1814           goto cleanup;
1815         }
1816     }
1817
1818 #define warn_or_error(...) \
1819 { \
1820   if (warn) \
1821     gfc_warning (__VA_ARGS__); \
1822   else \
1823     { \
1824       gfc_error (__VA_ARGS__); \
1825       goto cleanup; \
1826     } \
1827 }
1828
1829   /* Checks on the RECL specifier.  */
1830   if (open->recl && open->recl->expr_type == EXPR_CONSTANT
1831       && open->recl->ts.type == BT_INTEGER
1832       && mpz_sgn (open->recl->value.integer) != 1)
1833     {
1834       warn_or_error ("RECL in OPEN statement at %C must be positive");
1835     }
1836
1837   /* Checks on the STATUS specifier.  */
1838   if (open->status && open->status->expr_type == EXPR_CONSTANT)
1839     {
1840       static const char *status[] = { "OLD", "NEW", "SCRATCH",
1841         "REPLACE", "UNKNOWN", NULL };
1842
1843       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
1844                                       open->status->value.character.string,
1845                                       "OPEN", warn))
1846         goto cleanup;
1847
1848       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
1849          the FILE= specifier shall appear.  */
1850       if (open->file == NULL
1851           && (gfc_wide_strncasecmp (open->status->value.character.string,
1852                                     "replace", 7) == 0
1853               || gfc_wide_strncasecmp (open->status->value.character.string,
1854                                        "new", 3) == 0))
1855         {
1856           char *s = gfc_widechar_to_char (open->status->value.character.string,
1857                                           -1);
1858           warn_or_error ("The STATUS specified in OPEN statement at %C is "
1859                          "'%s' and no FILE specifier is present", s);
1860           gfc_free (s);
1861         }
1862
1863       /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
1864          the FILE= specifier shall not appear.  */
1865       if (gfc_wide_strncasecmp (open->status->value.character.string,
1866                                 "scratch", 7) == 0 && open->file)
1867         {
1868           warn_or_error ("The STATUS specified in OPEN statement at %C "
1869                          "cannot have the value SCRATCH if a FILE specifier "
1870                          "is present");
1871         }
1872     }
1873
1874   /* Things that are not allowed for unformatted I/O.  */
1875   if (open->form && open->form->expr_type == EXPR_CONSTANT
1876       && (open->delim || open->decimal || open->encoding || open->round
1877           || open->sign || open->pad || open->blank)
1878       && gfc_wide_strncasecmp (open->form->value.character.string,
1879                                "unformatted", 11) == 0)
1880     {
1881       const char *spec = (open->delim ? "DELIM "
1882                                       : (open->pad ? "PAD " : open->blank
1883                                                             ? "BLANK " : ""));
1884
1885       warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
1886                      "unformatted I/O", spec);
1887     }
1888
1889   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
1890       && gfc_wide_strncasecmp (open->access->value.character.string,
1891                                "stream", 6) == 0)
1892     {
1893       warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
1894                      "stream I/O");
1895     }
1896
1897   if (open->position
1898       && open->access && open->access->expr_type == EXPR_CONSTANT
1899       && !(gfc_wide_strncasecmp (open->access->value.character.string,
1900                                  "sequential", 10) == 0
1901            || gfc_wide_strncasecmp (open->access->value.character.string,
1902                                     "stream", 6) == 0
1903            || gfc_wide_strncasecmp (open->access->value.character.string,
1904                                     "append", 6) == 0))
1905     {
1906       warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
1907                      "for stream or sequential ACCESS");
1908     }
1909
1910 #undef warn_or_error
1911
1912   new_st.op = EXEC_OPEN;
1913   new_st.ext.open = open;
1914   return MATCH_YES;
1915
1916 syntax:
1917   gfc_syntax_error (ST_OPEN);
1918
1919 cleanup:
1920   gfc_free_open (open);
1921   return MATCH_ERROR;
1922 }
1923
1924
1925 /* Free a gfc_close structure an all its expressions.  */
1926
1927 void
1928 gfc_free_close (gfc_close *close)
1929 {
1930   if (close == NULL)
1931     return;
1932
1933   gfc_free_expr (close->unit);
1934   gfc_free_expr (close->iomsg);
1935   gfc_free_expr (close->iostat);
1936   gfc_free_expr (close->status);
1937   gfc_free (close);
1938 }
1939
1940
1941 /* Match elements of a CLOSE statement.  */
1942
1943 static match
1944 match_close_element (gfc_close *close)
1945 {
1946   match m;
1947
1948   m = match_etag (&tag_unit, &close->unit);
1949   if (m != MATCH_NO)
1950     return m;
1951   m = match_etag (&tag_status, &close->status);
1952   if (m != MATCH_NO)
1953     return m;
1954   m = match_out_tag (&tag_iomsg, &close->iomsg);
1955   if (m != MATCH_NO)
1956     return m;
1957   m = match_out_tag (&tag_iostat, &close->iostat);
1958   if (m != MATCH_NO)
1959     return m;
1960   m = match_ltag (&tag_err, &close->err);
1961   if (m != MATCH_NO)
1962     return m;
1963
1964   return MATCH_NO;
1965 }
1966
1967
1968 /* Match a CLOSE statement.  */
1969
1970 match
1971 gfc_match_close (void)
1972 {
1973   gfc_close *close;
1974   match m;
1975   bool warn;
1976
1977   m = gfc_match_char ('(');
1978   if (m == MATCH_NO)
1979     return m;
1980
1981   close = XCNEW (gfc_close);
1982
1983   m = match_close_element (close);
1984
1985   if (m == MATCH_ERROR)
1986     goto cleanup;
1987   if (m == MATCH_NO)
1988     {
1989       m = gfc_match_expr (&close->unit);
1990       if (m == MATCH_NO)
1991         goto syntax;
1992       if (m == MATCH_ERROR)
1993         goto cleanup;
1994     }
1995
1996   for (;;)
1997     {
1998       if (gfc_match_char (')') == MATCH_YES)
1999         break;
2000       if (gfc_match_char (',') != MATCH_YES)
2001         goto syntax;
2002
2003       m = match_close_element (close);
2004       if (m == MATCH_ERROR)
2005         goto cleanup;
2006       if (m == MATCH_NO)
2007         goto syntax;
2008     }
2009
2010   if (gfc_match_eos () == MATCH_NO)
2011     goto syntax;
2012
2013   if (gfc_pure (NULL))
2014     {
2015       gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2016       goto cleanup;
2017     }
2018
2019   warn = (close->iostat || close->err) ? true : false;
2020
2021   /* Checks on the STATUS specifier.  */
2022   if (close->status && close->status->expr_type == EXPR_CONSTANT)
2023     {
2024       static const char *status[] = { "KEEP", "DELETE", NULL };
2025
2026       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2027                                       close->status->value.character.string,
2028                                       "CLOSE", warn))
2029         goto cleanup;
2030     }
2031
2032   new_st.op = EXEC_CLOSE;
2033   new_st.ext.close = close;
2034   return MATCH_YES;
2035
2036 syntax:
2037   gfc_syntax_error (ST_CLOSE);
2038
2039 cleanup:
2040   gfc_free_close (close);
2041   return MATCH_ERROR;
2042 }
2043
2044
2045 /* Resolve everything in a gfc_close structure.  */
2046
2047 gfc_try
2048 gfc_resolve_close (gfc_close *close)
2049 {
2050   RESOLVE_TAG (&tag_unit, close->unit);
2051   RESOLVE_TAG (&tag_iomsg, close->iomsg);
2052   RESOLVE_TAG (&tag_iostat, close->iostat);
2053   RESOLVE_TAG (&tag_status, close->status);
2054
2055   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2056     return FAILURE;
2057
2058   return SUCCESS;
2059 }
2060
2061
2062 /* Free a gfc_filepos structure.  */
2063
2064 void
2065 gfc_free_filepos (gfc_filepos *fp)
2066 {
2067   gfc_free_expr (fp->unit);
2068   gfc_free_expr (fp->iomsg);
2069   gfc_free_expr (fp->iostat);
2070   gfc_free (fp);
2071 }
2072
2073
2074 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
2075
2076 static match
2077 match_file_element (gfc_filepos *fp)
2078 {
2079   match m;
2080
2081   m = match_etag (&tag_unit, &fp->unit);
2082   if (m != MATCH_NO)
2083     return m;
2084   m = match_out_tag (&tag_iomsg, &fp->iomsg);
2085   if (m != MATCH_NO)
2086     return m;
2087   m = match_out_tag (&tag_iostat, &fp->iostat);
2088   if (m != MATCH_NO)
2089     return m;
2090   m = match_ltag (&tag_err, &fp->err);
2091   if (m != MATCH_NO)
2092     return m;
2093
2094   return MATCH_NO;
2095 }
2096
2097
2098 /* Match the second half of the file-positioning statements, REWIND,
2099    BACKSPACE, ENDFILE, or the FLUSH statement.  */
2100
2101 static match
2102 match_filepos (gfc_statement st, gfc_exec_op op)
2103 {
2104   gfc_filepos *fp;
2105   match m;
2106
2107   fp = XCNEW (gfc_filepos);
2108
2109   if (gfc_match_char ('(') == MATCH_NO)
2110     {
2111       m = gfc_match_expr (&fp->unit);
2112       if (m == MATCH_ERROR)
2113         goto cleanup;
2114       if (m == MATCH_NO)
2115         goto syntax;
2116
2117       goto done;
2118     }
2119
2120   m = match_file_element (fp);
2121   if (m == MATCH_ERROR)
2122     goto done;
2123   if (m == MATCH_NO)
2124     {
2125       m = gfc_match_expr (&fp->unit);
2126       if (m == MATCH_ERROR)
2127         goto done;
2128       if (m == MATCH_NO)
2129         goto syntax;
2130     }
2131
2132   for (;;)
2133     {
2134       if (gfc_match_char (')') == MATCH_YES)
2135         break;
2136       if (gfc_match_char (',') != MATCH_YES)
2137         goto syntax;
2138
2139       m = match_file_element (fp);
2140       if (m == MATCH_ERROR)
2141         goto cleanup;
2142       if (m == MATCH_NO)
2143         goto syntax;
2144     }
2145
2146 done:
2147   if (gfc_match_eos () != MATCH_YES)
2148     goto syntax;
2149
2150   if (gfc_pure (NULL))
2151     {
2152       gfc_error ("%s statement not allowed in PURE procedure at %C",
2153                  gfc_ascii_statement (st));
2154
2155       goto cleanup;
2156     }
2157
2158   new_st.op = op;
2159   new_st.ext.filepos = fp;
2160   return MATCH_YES;
2161
2162 syntax:
2163   gfc_syntax_error (st);
2164
2165 cleanup:
2166   gfc_free_filepos (fp);
2167   return MATCH_ERROR;
2168 }
2169
2170
2171 gfc_try
2172 gfc_resolve_filepos (gfc_filepos *fp)
2173 {
2174   RESOLVE_TAG (&tag_unit, fp->unit);
2175   RESOLVE_TAG (&tag_iostat, fp->iostat);
2176   RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2177   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2178     return FAILURE;
2179
2180   return SUCCESS;
2181 }
2182
2183
2184 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2185    and the FLUSH statement.  */
2186
2187 match
2188 gfc_match_endfile (void)
2189 {
2190   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2191 }
2192
2193 match
2194 gfc_match_backspace (void)
2195 {
2196   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2197 }
2198
2199 match
2200 gfc_match_rewind (void)
2201 {
2202   return match_filepos (ST_REWIND, EXEC_REWIND);
2203 }
2204
2205 match
2206 gfc_match_flush (void)
2207 {
2208   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2209       == FAILURE)
2210     return MATCH_ERROR;
2211
2212   return match_filepos (ST_FLUSH, EXEC_FLUSH);
2213 }
2214
2215 /******************** Data Transfer Statements *********************/
2216
2217 /* Return a default unit number.  */
2218
2219 static gfc_expr *
2220 default_unit (io_kind k)
2221 {
2222   int unit;
2223
2224   if (k == M_READ)
2225     unit = 5;
2226   else
2227     unit = 6;
2228
2229   return gfc_int_expr (unit);
2230 }
2231
2232
2233 /* Match a unit specification for a data transfer statement.  */
2234
2235 static match
2236 match_dt_unit (io_kind k, gfc_dt *dt)
2237 {
2238   gfc_expr *e;
2239
2240   if (gfc_match_char ('*') == MATCH_YES)
2241     {
2242       if (dt->io_unit != NULL)
2243         goto conflict;
2244
2245       dt->io_unit = default_unit (k);
2246       return MATCH_YES;
2247     }
2248
2249   if (gfc_match_expr (&e) == MATCH_YES)
2250     {
2251       if (dt->io_unit != NULL)
2252         {
2253           gfc_free_expr (e);
2254           goto conflict;
2255         }
2256
2257       dt->io_unit = e;
2258       return MATCH_YES;
2259     }
2260
2261   return MATCH_NO;
2262
2263 conflict:
2264   gfc_error ("Duplicate UNIT specification at %C");
2265   return MATCH_ERROR;
2266 }
2267
2268
2269 /* Match a format specification.  */
2270
2271 static match
2272 match_dt_format (gfc_dt *dt)
2273 {
2274   locus where;
2275   gfc_expr *e;
2276   gfc_st_label *label;
2277   match m;
2278
2279   where = gfc_current_locus;
2280
2281   if (gfc_match_char ('*') == MATCH_YES)
2282     {
2283       if (dt->format_expr != NULL || dt->format_label != NULL)
2284         goto conflict;
2285
2286       dt->format_label = &format_asterisk;
2287       return MATCH_YES;
2288     }
2289
2290   if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2291     {
2292       if (dt->format_expr != NULL || dt->format_label != NULL)
2293         {
2294           gfc_free_st_label (label);
2295           goto conflict;
2296         }
2297
2298       if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2299         return MATCH_ERROR;
2300
2301       dt->format_label = label;
2302       return MATCH_YES;
2303     }
2304   else if (m == MATCH_ERROR)
2305     /* The label was zero or too large.  Emit the correct diagnosis.  */
2306     return MATCH_ERROR;
2307
2308   if (gfc_match_expr (&e) == MATCH_YES)
2309     {
2310       if (dt->format_expr != NULL || dt->format_label != NULL)
2311         {
2312           gfc_free_expr (e);
2313           goto conflict;
2314         }
2315       dt->format_expr = e;
2316       return MATCH_YES;
2317     }
2318
2319   gfc_current_locus = where;    /* The only case where we have to restore */
2320
2321   return MATCH_NO;
2322
2323 conflict:
2324   gfc_error ("Duplicate format specification at %C");
2325   return MATCH_ERROR;
2326 }
2327
2328
2329 /* Traverse a namelist that is part of a READ statement to make sure
2330    that none of the variables in the namelist are INTENT(IN).  Returns
2331    nonzero if we find such a variable.  */
2332
2333 static int
2334 check_namelist (gfc_symbol *sym)
2335 {
2336   gfc_namelist *p;
2337
2338   for (p = sym->namelist; p; p = p->next)
2339     if (p->sym->attr.intent == INTENT_IN)
2340       {
2341         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2342                    p->sym->name, sym->name);
2343         return 1;
2344       }
2345
2346   return 0;
2347 }
2348
2349
2350 /* Match a single data transfer element.  */
2351
2352 static match
2353 match_dt_element (io_kind k, gfc_dt *dt)
2354 {
2355   char name[GFC_MAX_SYMBOL_LEN + 1];
2356   gfc_symbol *sym;
2357   match m;
2358
2359   if (gfc_match (" unit =") == MATCH_YES)
2360     {
2361       m = match_dt_unit (k, dt);
2362       if (m != MATCH_NO)
2363         return m;
2364     }
2365
2366   if (gfc_match (" fmt =") == MATCH_YES)
2367     {
2368       m = match_dt_format (dt);
2369       if (m != MATCH_NO)
2370         return m;
2371     }
2372
2373   if (gfc_match (" nml = %n", name) == MATCH_YES)
2374     {
2375       if (dt->namelist != NULL)
2376         {
2377           gfc_error ("Duplicate NML specification at %C");
2378           return MATCH_ERROR;
2379         }
2380
2381       if (gfc_find_symbol (name, NULL, 1, &sym))
2382         return MATCH_ERROR;
2383
2384       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2385         {
2386           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2387                      sym != NULL ? sym->name : name);
2388           return MATCH_ERROR;
2389         }
2390
2391       dt->namelist = sym;
2392       if (k == M_READ && check_namelist (sym))
2393         return MATCH_ERROR;
2394
2395       return MATCH_YES;
2396     }
2397
2398   m = match_etag (&tag_e_async, &dt->asynchronous);
2399   if (m != MATCH_NO)
2400     return m;
2401   m = match_etag (&tag_e_blank, &dt->blank);
2402   if (m != MATCH_NO)
2403     return m;
2404   m = match_etag (&tag_e_delim, &dt->delim);
2405   if (m != MATCH_NO)
2406     return m;
2407   m = match_etag (&tag_e_pad, &dt->pad);
2408   if (m != MATCH_NO)
2409     return m;
2410   m = match_etag (&tag_e_sign, &dt->sign);
2411   if (m != MATCH_NO)
2412     return m;
2413   m = match_etag (&tag_e_round, &dt->round);
2414   if (m != MATCH_NO)
2415     return m;
2416   m = match_out_tag (&tag_id, &dt->id);
2417   if (m != MATCH_NO)
2418     return m;
2419   m = match_etag (&tag_e_decimal, &dt->decimal);
2420   if (m != MATCH_NO)
2421     return m;
2422   m = match_etag (&tag_rec, &dt->rec);
2423   if (m != MATCH_NO)
2424     return m;
2425   m = match_etag (&tag_spos, &dt->pos);
2426   if (m != MATCH_NO)
2427     return m;
2428   m = match_out_tag (&tag_iomsg, &dt->iomsg);
2429   if (m != MATCH_NO)
2430     return m;
2431   m = match_out_tag (&tag_iostat, &dt->iostat);
2432   if (m != MATCH_NO)
2433     return m;
2434   m = match_ltag (&tag_err, &dt->err);
2435   if (m == MATCH_YES)
2436     dt->err_where = gfc_current_locus;
2437   if (m != MATCH_NO)
2438     return m;
2439   m = match_etag (&tag_advance, &dt->advance);
2440   if (m != MATCH_NO)
2441     return m;
2442   m = match_out_tag (&tag_size, &dt->size);
2443   if (m != MATCH_NO)
2444     return m;
2445
2446   m = match_ltag (&tag_end, &dt->end);
2447   if (m == MATCH_YES)
2448     {
2449       if (k == M_WRITE)
2450        {
2451          gfc_error ("END tag at %C not allowed in output statement");
2452          return MATCH_ERROR;
2453        }
2454       dt->end_where = gfc_current_locus;
2455     }
2456   if (m != MATCH_NO)
2457     return m;
2458
2459   m = match_ltag (&tag_eor, &dt->eor);
2460   if (m == MATCH_YES)
2461     dt->eor_where = gfc_current_locus;
2462   if (m != MATCH_NO)
2463     return m;
2464
2465   return MATCH_NO;
2466 }
2467
2468
2469 /* Free a data transfer structure and everything below it.  */
2470
2471 void
2472 gfc_free_dt (gfc_dt *dt)
2473 {
2474   if (dt == NULL)
2475     return;
2476
2477   gfc_free_expr (dt->io_unit);
2478   gfc_free_expr (dt->format_expr);
2479   gfc_free_expr (dt->rec);
2480   gfc_free_expr (dt->advance);
2481   gfc_free_expr (dt->iomsg);
2482   gfc_free_expr (dt->iostat);
2483   gfc_free_expr (dt->size);
2484   gfc_free_expr (dt->pad);
2485   gfc_free_expr (dt->delim);
2486   gfc_free_expr (dt->sign);
2487   gfc_free_expr (dt->round);
2488   gfc_free_expr (dt->blank);
2489   gfc_free_expr (dt->decimal);
2490   gfc_free_expr (dt->extra_comma);
2491   gfc_free_expr (dt->pos);
2492   gfc_free (dt);
2493 }
2494
2495
2496 /* Resolve everything in a gfc_dt structure.  */
2497
2498 gfc_try
2499 gfc_resolve_dt (gfc_dt *dt)
2500 {
2501   gfc_expr *e;
2502
2503   RESOLVE_TAG (&tag_format, dt->format_expr);
2504   RESOLVE_TAG (&tag_rec, dt->rec);
2505   RESOLVE_TAG (&tag_spos, dt->pos);
2506   RESOLVE_TAG (&tag_advance, dt->advance);
2507   RESOLVE_TAG (&tag_id, dt->id);
2508   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2509   RESOLVE_TAG (&tag_iostat, dt->iostat);
2510   RESOLVE_TAG (&tag_size, dt->size);
2511   RESOLVE_TAG (&tag_e_pad, dt->pad);
2512   RESOLVE_TAG (&tag_e_delim, dt->delim);
2513   RESOLVE_TAG (&tag_e_sign, dt->sign);
2514   RESOLVE_TAG (&tag_e_round, dt->round);
2515   RESOLVE_TAG (&tag_e_blank, dt->blank);
2516   RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2517   RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2518
2519   e = dt->io_unit;
2520   if (gfc_resolve_expr (e) == SUCCESS
2521       && (e->ts.type != BT_INTEGER
2522           && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2523     {
2524       /* If there is no extra comma signifying the "format" form of the IO
2525          statement, then this must be an error.  */
2526       if (!dt->extra_comma)
2527         {
2528           gfc_error ("UNIT specification at %L must be an INTEGER expression "
2529                      "or a CHARACTER variable", &e->where);
2530           return FAILURE;
2531         }
2532       else
2533         {
2534           /* At this point, we have an extra comma.  If io_unit has arrived as
2535              type character, we assume its really the "format" form of the I/O
2536              statement.  We set the io_unit to the default unit and format to
2537              the character expression.  See F95 Standard section 9.4.  */
2538           io_kind k;
2539           k = dt->extra_comma->value.iokind;
2540           if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2541             {
2542               dt->format_expr = dt->io_unit;
2543               dt->io_unit = default_unit (k);
2544
2545               /* Free this pointer now so that a warning/error is not triggered
2546                  below for the "Extension".  */
2547               gfc_free_expr (dt->extra_comma);
2548               dt->extra_comma = NULL;
2549             }
2550
2551           if (k == M_WRITE)
2552             {
2553               gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2554                          &dt->extra_comma->where);
2555               return FAILURE;
2556             }
2557         }
2558     }
2559
2560   if (e->ts.type == BT_CHARACTER)
2561     {
2562       if (gfc_has_vector_index (e))
2563         {
2564           gfc_error ("Internal unit with vector subscript at %L", &e->where);
2565           return FAILURE;
2566         }
2567     }
2568
2569   if (e->rank && e->ts.type != BT_CHARACTER)
2570     {
2571       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2572       return FAILURE;
2573     }
2574
2575   if (dt->extra_comma
2576       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2577                          "item list at %L", &dt->extra_comma->where) == FAILURE)
2578     return FAILURE;
2579
2580   if (dt->err)
2581     {
2582       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2583         return FAILURE;
2584       if (dt->err->defined == ST_LABEL_UNKNOWN)
2585         {
2586           gfc_error ("ERR tag label %d at %L not defined",
2587                       dt->err->value, &dt->err_where);
2588           return FAILURE;
2589         }
2590     }
2591
2592   if (dt->end)
2593     {
2594       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2595         return FAILURE;
2596       if (dt->end->defined == ST_LABEL_UNKNOWN)
2597         {
2598           gfc_error ("END tag label %d at %L not defined",
2599                       dt->end->value, &dt->end_where);
2600           return FAILURE;
2601         }
2602     }
2603
2604   if (dt->eor)
2605     {
2606       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2607         return FAILURE;
2608       if (dt->eor->defined == ST_LABEL_UNKNOWN)
2609         {
2610           gfc_error ("EOR tag label %d at %L not defined",
2611                       dt->eor->value, &dt->eor_where);
2612           return FAILURE;
2613         }
2614     }
2615
2616   /* Check the format label actually exists.  */
2617   if (dt->format_label && dt->format_label != &format_asterisk
2618       && dt->format_label->defined == ST_LABEL_UNKNOWN)
2619     {
2620       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2621                  &dt->format_label->where);
2622       return FAILURE;
2623     }
2624   return SUCCESS;
2625 }
2626
2627
2628 /* Given an io_kind, return its name.  */
2629
2630 static const char *
2631 io_kind_name (io_kind k)
2632 {
2633   const char *name;
2634
2635   switch (k)
2636     {
2637     case M_READ:
2638       name = "READ";
2639       break;
2640     case M_WRITE:
2641       name = "WRITE";
2642       break;
2643     case M_PRINT:
2644       name = "PRINT";
2645       break;
2646     case M_INQUIRE:
2647       name = "INQUIRE";
2648       break;
2649     default:
2650       gfc_internal_error ("io_kind_name(): bad I/O-kind");
2651     }
2652
2653   return name;
2654 }
2655
2656
2657 /* Match an IO iteration statement of the form:
2658
2659    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2660
2661    which is equivalent to a single IO element.  This function is
2662    mutually recursive with match_io_element().  */
2663
2664 static match match_io_element (io_kind, gfc_code **);
2665
2666 static match
2667 match_io_iterator (io_kind k, gfc_code **result)
2668 {
2669   gfc_code *head, *tail, *new_code;
2670   gfc_iterator *iter;
2671   locus old_loc;
2672   match m;
2673   int n;
2674
2675   iter = NULL;
2676   head = NULL;
2677   old_loc = gfc_current_locus;
2678
2679   if (gfc_match_char ('(') != MATCH_YES)
2680     return MATCH_NO;
2681
2682   m = match_io_element (k, &head);
2683   tail = head;
2684
2685   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2686     {
2687       m = MATCH_NO;
2688       goto cleanup;
2689     }
2690
2691   /* Can't be anything but an IO iterator.  Build a list.  */
2692   iter = gfc_get_iterator ();
2693
2694   for (n = 1;; n++)
2695     {
2696       m = gfc_match_iterator (iter, 0);
2697       if (m == MATCH_ERROR)
2698         goto cleanup;
2699       if (m == MATCH_YES)
2700         {
2701           gfc_check_do_variable (iter->var->symtree);
2702           break;
2703         }
2704
2705       m = match_io_element (k, &new_code);
2706       if (m == MATCH_ERROR)
2707         goto cleanup;
2708       if (m == MATCH_NO)
2709         {
2710           if (n > 2)
2711             goto syntax;
2712           goto cleanup;
2713         }
2714
2715       tail = gfc_append_code (tail, new_code);
2716
2717       if (gfc_match_char (',') != MATCH_YES)
2718         {
2719           if (n > 2)
2720             goto syntax;
2721           m = MATCH_NO;
2722           goto cleanup;
2723         }
2724     }
2725
2726   if (gfc_match_char (')') != MATCH_YES)
2727     goto syntax;
2728
2729   new_code = gfc_get_code ();
2730   new_code->op = EXEC_DO;
2731   new_code->ext.iterator = iter;
2732
2733   new_code->block = gfc_get_code ();
2734   new_code->block->op = EXEC_DO;
2735   new_code->block->next = head;
2736
2737   *result = new_code;
2738   return MATCH_YES;
2739
2740 syntax:
2741   gfc_error ("Syntax error in I/O iterator at %C");
2742   m = MATCH_ERROR;
2743
2744 cleanup:
2745   gfc_free_iterator (iter, 1);
2746   gfc_free_statements (head);
2747   gfc_current_locus = old_loc;
2748   return m;
2749 }
2750
2751
2752 /* Match a single element of an IO list, which is either a single
2753    expression or an IO Iterator.  */
2754
2755 static match
2756 match_io_element (io_kind k, gfc_code **cpp)
2757 {
2758   gfc_expr *expr;
2759   gfc_code *cp;
2760   match m;
2761
2762   expr = NULL;
2763
2764   m = match_io_iterator (k, cpp);
2765   if (m == MATCH_YES)
2766     return MATCH_YES;
2767
2768   if (k == M_READ)
2769     {
2770       m = gfc_match_variable (&expr, 0);
2771       if (m == MATCH_NO)
2772         gfc_error ("Expected variable in READ statement at %C");
2773     }
2774   else
2775     {
2776       m = gfc_match_expr (&expr);
2777       if (m == MATCH_NO)
2778         gfc_error ("Expected expression in %s statement at %C",
2779                    io_kind_name (k));
2780     }
2781
2782   if (m == MATCH_YES)
2783     switch (k)
2784       {
2785       case M_READ:
2786         if (expr->symtree->n.sym->attr.intent == INTENT_IN)
2787           {
2788             gfc_error ("Variable '%s' in input list at %C cannot be "
2789                        "INTENT(IN)", expr->symtree->n.sym->name);
2790             m = MATCH_ERROR;
2791           }
2792
2793         if (gfc_pure (NULL)
2794             && gfc_impure_variable (expr->symtree->n.sym)
2795             && current_dt->io_unit->ts.type == BT_CHARACTER)
2796           {
2797             gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
2798                        expr->symtree->n.sym->name);
2799             m = MATCH_ERROR;
2800           }
2801
2802         if (gfc_check_do_variable (expr->symtree))
2803           m = MATCH_ERROR;
2804
2805         break;
2806
2807       case M_WRITE:
2808         if (current_dt->io_unit->ts.type == BT_CHARACTER
2809             && gfc_pure (NULL)
2810             && current_dt->io_unit->expr_type == EXPR_VARIABLE
2811             && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
2812           {
2813             gfc_error ("Cannot write to internal file unit '%s' at %C "
2814                        "inside a PURE procedure",
2815                        current_dt->io_unit->symtree->n.sym->name);
2816             m = MATCH_ERROR;
2817           }
2818
2819         break;
2820
2821       default:
2822         break;
2823       }
2824
2825   if (m != MATCH_YES)
2826     {
2827       gfc_free_expr (expr);
2828       return MATCH_ERROR;
2829     }
2830
2831   cp = gfc_get_code ();
2832   cp->op = EXEC_TRANSFER;
2833   cp->expr = expr;
2834
2835   *cpp = cp;
2836   return MATCH_YES;
2837 }
2838
2839
2840 /* Match an I/O list, building gfc_code structures as we go.  */
2841
2842 static match
2843 match_io_list (io_kind k, gfc_code **head_p)
2844 {
2845   gfc_code *head, *tail, *new_code;
2846   match m;
2847
2848   *head_p = head = tail = NULL;
2849   if (gfc_match_eos () == MATCH_YES)
2850     return MATCH_YES;
2851
2852   for (;;)
2853     {
2854       m = match_io_element (k, &new_code);
2855       if (m == MATCH_ERROR)
2856         goto cleanup;
2857       if (m == MATCH_NO)
2858         goto syntax;
2859
2860       tail = gfc_append_code (tail, new_code);
2861       if (head == NULL)
2862         head = new_code;
2863
2864       if (gfc_match_eos () == MATCH_YES)
2865         break;
2866       if (gfc_match_char (',') != MATCH_YES)
2867         goto syntax;
2868     }
2869
2870   *head_p = head;
2871   return MATCH_YES;
2872
2873 syntax:
2874   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2875
2876 cleanup:
2877   gfc_free_statements (head);
2878   return MATCH_ERROR;
2879 }
2880
2881
2882 /* Attach the data transfer end node.  */
2883
2884 static void
2885 terminate_io (gfc_code *io_code)
2886 {
2887   gfc_code *c;
2888
2889   if (io_code == NULL)
2890     io_code = new_st.block;
2891
2892   c = gfc_get_code ();
2893   c->op = EXEC_DT_END;
2894
2895   /* Point to structure that is already there */
2896   c->ext.dt = new_st.ext.dt;
2897   gfc_append_code (io_code, c);
2898 }
2899
2900
2901 /* Check the constraints for a data transfer statement.  The majority of the
2902    constraints appearing in 9.4 of the standard appear here.  Some are handled
2903    in resolve_tag and others in gfc_resolve_dt.  */
2904
2905 static match
2906 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
2907                       locus *spec_end)
2908 {
2909 #define io_constraint(condition,msg,arg)\
2910 if (condition) \
2911   {\
2912     gfc_error(msg,arg);\
2913     m = MATCH_ERROR;\
2914   }
2915
2916   match m;
2917   gfc_expr *expr;
2918   gfc_symbol *sym = NULL;
2919   bool warn, unformatted;
2920
2921   warn = (dt->err || dt->iostat) ? true : false;
2922   unformatted = dt->format_expr == NULL && dt->format_label == NULL
2923                 && dt->namelist == NULL;
2924
2925   m = MATCH_YES;
2926
2927   expr = dt->io_unit;
2928   if (expr && expr->expr_type == EXPR_VARIABLE
2929       && expr->ts.type == BT_CHARACTER)
2930     {
2931       sym = expr->symtree->n.sym;
2932
2933       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
2934                      "Internal file at %L must not be INTENT(IN)",
2935                      &expr->where);
2936
2937       io_constraint (gfc_has_vector_index (dt->io_unit),
2938                      "Internal file incompatible with vector subscript at %L",
2939                      &expr->where);
2940
2941       io_constraint (dt->rec != NULL,
2942                      "REC tag at %L is incompatible with internal file",
2943                      &dt->rec->where);
2944
2945       io_constraint (dt->pos != NULL,
2946                      "POS tag at %L is incompatible with internal file",
2947                      &dt->pos->where);
2948
2949       io_constraint (unformatted,
2950                      "Unformatted I/O not allowed with internal unit at %L",
2951                      &dt->io_unit->where);
2952
2953       io_constraint (dt->asynchronous != NULL,
2954                      "ASYNCHRONOUS tag at %L not allowed with internal file",
2955                      &dt->asynchronous->where);
2956
2957       if (dt->namelist != NULL)
2958         {
2959           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
2960                               "at %L with namelist", &expr->where)
2961               == FAILURE)
2962             m = MATCH_ERROR;
2963         }
2964
2965       io_constraint (dt->advance != NULL,
2966                      "ADVANCE tag at %L is incompatible with internal file",
2967                      &dt->advance->where);
2968     }
2969
2970   if (expr && expr->ts.type != BT_CHARACTER)
2971     {
2972
2973       io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
2974                      "IO UNIT in %s statement at %C must be "
2975                      "an internal file in a PURE procedure",
2976                      io_kind_name (k));
2977     }
2978
2979   if (k != M_READ)
2980     {
2981       io_constraint (dt->end, "END tag not allowed with output at %L",
2982                      &dt->end_where);
2983
2984       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
2985                      &dt->eor_where);
2986
2987       io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
2988                      &dt->blank->where);
2989
2990       io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
2991                      &dt->pad->where);
2992
2993       io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
2994                      &dt->size->where);
2995     }
2996   else
2997     {
2998       io_constraint (dt->size && dt->advance == NULL,
2999                      "SIZE tag at %L requires an ADVANCE tag",
3000                      &dt->size->where);
3001
3002       io_constraint (dt->eor && dt->advance == NULL,
3003                      "EOR tag at %L requires an ADVANCE tag",
3004                      &dt->eor_where);
3005     }
3006
3007   if (dt->asynchronous)
3008     {
3009       static const char * asynchronous[] = { "YES", "NO", NULL };
3010
3011       if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3012         {
3013           gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3014                      "expression", &dt->asynchronous->where);
3015           return MATCH_ERROR;
3016         }
3017
3018       if (!compare_to_allowed_values
3019                 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3020                  dt->asynchronous->value.character.string,
3021                  io_kind_name (k), warn))
3022         return MATCH_ERROR;
3023     }
3024
3025   if (dt->id)
3026     {
3027       bool not_yes
3028         = !dt->asynchronous
3029           || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3030           || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3031                                    "yes", 3) != 0;
3032       io_constraint (not_yes,
3033                      "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3034                      "specifier", &dt->id->where);
3035     }
3036
3037   if (dt->decimal)
3038     {
3039       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3040           "not allowed in Fortran 95") == FAILURE)
3041         return MATCH_ERROR;
3042
3043       if (dt->decimal->expr_type == EXPR_CONSTANT)
3044         {
3045           static const char * decimal[] = { "COMMA", "POINT", NULL };
3046
3047           if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3048                                           dt->decimal->value.character.string,
3049                                           io_kind_name (k), warn))
3050             return MATCH_ERROR;
3051
3052           io_constraint (unformatted,
3053                          "the DECIMAL= specifier at %L must be with an "
3054                          "explicit format expression", &dt->decimal->where);
3055         }
3056     }
3057
3058   if (dt->blank)
3059     {
3060       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3061           "not allowed in Fortran 95") == FAILURE)
3062         return MATCH_ERROR;
3063
3064       if (dt->blank->expr_type == EXPR_CONSTANT)
3065         {
3066           static const char * blank[] = { "NULL", "ZERO", NULL };
3067
3068           if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3069                                           dt->blank->value.character.string,
3070                                           io_kind_name (k), warn))
3071             return MATCH_ERROR;
3072
3073           io_constraint (unformatted,
3074                          "the BLANK= specifier at %L must be with an "
3075                          "explicit format expression", &dt->blank->where);
3076         }
3077     }
3078
3079   if (dt->pad)
3080     {
3081       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3082           "not allowed in Fortran 95") == FAILURE)
3083         return MATCH_ERROR;
3084
3085       if (dt->pad->expr_type == EXPR_CONSTANT)
3086         {
3087           static const char * pad[] = { "YES", "NO", NULL };
3088
3089           if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3090                                           dt->pad->value.character.string,
3091                                           io_kind_name (k), warn))
3092             return MATCH_ERROR;
3093
3094           io_constraint (unformatted,
3095                          "the PAD= specifier at %L must be with an "
3096                          "explicit format expression", &dt->pad->where);
3097         }
3098     }
3099
3100   if (dt->round)
3101     {
3102       /* When implemented, change the following to use gfc_notify_std F2003.
3103       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3104           "not allowed in Fortran 95") == FAILURE)
3105         return MATCH_ERROR;  */
3106       gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
3107       return MATCH_ERROR;
3108
3109       if (dt->round->expr_type == EXPR_CONSTANT)
3110         {
3111           static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3112                                           "COMPATIBLE", "PROCESSOR_DEFINED",
3113                                           NULL };
3114
3115           if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3116                                           dt->round->value.character.string,
3117                                           io_kind_name (k), warn))
3118             return MATCH_ERROR;
3119         }
3120     }
3121
3122   if (dt->sign)
3123     {
3124       /* When implemented, change the following to use gfc_notify_std F2003.
3125       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3126           "not allowed in Fortran 95") == FAILURE)
3127         return MATCH_ERROR;  */
3128       if (dt->sign->expr_type == EXPR_CONSTANT)
3129         {
3130           static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3131                                          NULL };
3132
3133           if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3134                                       dt->sign->value.character.string,
3135                                       io_kind_name (k), warn))
3136             return MATCH_ERROR;
3137
3138           io_constraint (unformatted,
3139                          "SIGN= specifier at %L must be with an "
3140                          "explicit format expression", &dt->sign->where);
3141
3142           io_constraint (k == M_READ,
3143                          "SIGN= specifier at %L not allowed in a "
3144                          "READ statement", &dt->sign->where);
3145         }
3146     }
3147
3148   if (dt->delim)
3149     {
3150       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3151           "not allowed in Fortran 95") == FAILURE)
3152         return MATCH_ERROR;
3153
3154       if (dt->delim->expr_type == EXPR_CONSTANT)
3155         {
3156           static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3157
3158           if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3159                                           dt->delim->value.character.string,
3160                                           io_kind_name (k), warn))
3161             return MATCH_ERROR;
3162
3163           io_constraint (k == M_READ,
3164                          "DELIM= specifier at %L not allowed in a "
3165                          "READ statement", &dt->delim->where);
3166
3167           io_constraint (dt->format_label != &format_asterisk
3168                          && dt->namelist == NULL,
3169                          "DELIM= specifier at %L must have FMT=*",
3170                          &dt->delim->where);
3171
3172           io_constraint (unformatted && dt->namelist == NULL,
3173                          "DELIM= specifier at %L must be with FMT=* or "
3174                          "NML= specifier ", &dt->delim->where);
3175         }
3176     }
3177
3178   if (dt->namelist)
3179     {
3180       io_constraint (io_code && dt->namelist,
3181                      "NAMELIST cannot be followed by IO-list at %L",
3182                      &io_code->loc);
3183
3184       io_constraint (dt->format_expr,
3185                      "IO spec-list cannot contain both NAMELIST group name "
3186                      "and format specification at %L",
3187                      &dt->format_expr->where);
3188
3189       io_constraint (dt->format_label,
3190                      "IO spec-list cannot contain both NAMELIST group name "
3191                      "and format label at %L", spec_end);
3192
3193       io_constraint (dt->rec,
3194                      "NAMELIST IO is not allowed with a REC= specifier "
3195                      "at %L", &dt->rec->where);
3196
3197       io_constraint (dt->advance,
3198                      "NAMELIST IO is not allowed with a ADVANCE= specifier "
3199                      "at %L", &dt->advance->where);
3200     }
3201
3202   if (dt->rec)
3203     {
3204       io_constraint (dt->end,
3205                      "An END tag is not allowed with a "
3206                      "REC= specifier at %L", &dt->end_where);
3207
3208       io_constraint (dt->format_label == &format_asterisk,
3209                      "FMT=* is not allowed with a REC= specifier "
3210                      "at %L", spec_end);
3211
3212       io_constraint (dt->pos,
3213                      "POS= is not allowed with REC= specifier "
3214                      "at %L", &dt->pos->where);
3215     }
3216
3217   if (dt->advance)
3218     {
3219       int not_yes, not_no;
3220       expr = dt->advance;
3221
3222       io_constraint (dt->format_label == &format_asterisk,
3223                      "List directed format(*) is not allowed with a "
3224                      "ADVANCE= specifier at %L.", &expr->where);
3225
3226       io_constraint (unformatted,
3227                      "the ADVANCE= specifier at %L must appear with an "
3228                      "explicit format expression", &expr->where);
3229
3230       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3231         {
3232           const gfc_char_t *advance = expr->value.character.string;
3233           not_no = gfc_wide_strlen (advance) != 2
3234                    || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3235           not_yes = gfc_wide_strlen (advance) != 3
3236                     || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3237         }
3238       else
3239         {
3240           not_no = 0;
3241           not_yes = 0;
3242         }
3243
3244       io_constraint (not_no && not_yes,
3245                      "ADVANCE= specifier at %L must have value = "
3246                      "YES or NO.", &expr->where);
3247
3248       io_constraint (dt->size && not_no && k == M_READ,
3249                      "SIZE tag at %L requires an ADVANCE = 'NO'",
3250                      &dt->size->where);
3251
3252       io_constraint (dt->eor && not_no && k == M_READ,
3253                      "EOR tag at %L requires an ADVANCE = 'NO'",
3254                      &dt->eor_where);
3255     }
3256
3257   expr = dt->format_expr;
3258   if (gfc_simplify_expr (expr, 0) == FAILURE
3259       || check_format_string (expr, k == M_READ) == FAILURE)
3260     return MATCH_ERROR;
3261
3262   return m;
3263 }
3264 #undef io_constraint
3265
3266
3267 /* Match a READ, WRITE or PRINT statement.  */
3268
3269 static match
3270 match_io (io_kind k)
3271 {
3272   char name[GFC_MAX_SYMBOL_LEN + 1];
3273   gfc_code *io_code;
3274   gfc_symbol *sym;
3275   int comma_flag;
3276   locus where;
3277   locus spec_end;
3278   gfc_dt *dt;
3279   match m;
3280
3281   where = gfc_current_locus;
3282   comma_flag = 0;
3283   current_dt = dt = XCNEW (gfc_dt);
3284   m = gfc_match_char ('(');
3285   if (m == MATCH_NO)
3286     {
3287       where = gfc_current_locus;
3288       if (k == M_WRITE)
3289         goto syntax;
3290       else if (k == M_PRINT)
3291         {
3292           /* Treat the non-standard case of PRINT namelist.  */
3293           if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3294               && gfc_match_name (name) == MATCH_YES)
3295             {
3296               gfc_find_symbol (name, NULL, 1, &sym);
3297               if (sym && sym->attr.flavor == FL_NAMELIST)
3298                 {
3299                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3300                                       "%C is an extension") == FAILURE)
3301                     {
3302                       m = MATCH_ERROR;
3303                       goto cleanup;
3304                     }
3305
3306                   dt->io_unit = default_unit (k);
3307                   dt->namelist = sym;
3308                   goto get_io_list;
3309                 }
3310               else
3311                 gfc_current_locus = where;
3312             }
3313         }
3314
3315       if (gfc_current_form == FORM_FREE)
3316         {
3317           char c = gfc_peek_ascii_char ();
3318           if (c != ' ' && c != '*' && c != '\'' && c != '"')
3319             {
3320               m = MATCH_NO;
3321               goto cleanup;
3322             }
3323         }
3324
3325       m = match_dt_format (dt);
3326       if (m == MATCH_ERROR)
3327         goto cleanup;
3328       if (m == MATCH_NO)
3329         goto syntax;
3330
3331       comma_flag = 1;
3332       dt->io_unit = default_unit (k);
3333       goto get_io_list;
3334     }
3335   else
3336     {
3337       /* Before issuing an error for a malformed 'print (1,*)' type of
3338          error, check for a default-char-expr of the form ('(I0)').  */
3339       if (k == M_PRINT && m == MATCH_YES)
3340         {
3341           /* Reset current locus to get the initial '(' in an expression.  */
3342           gfc_current_locus = where;
3343           dt->format_expr = NULL;
3344           m = match_dt_format (dt);
3345
3346           if (m == MATCH_ERROR)
3347             goto cleanup;
3348           if (m == MATCH_NO || dt->format_expr == NULL)
3349             goto syntax;
3350
3351           comma_flag = 1;
3352           dt->io_unit = default_unit (k);
3353           goto get_io_list;
3354         }
3355     }
3356
3357   /* Match a control list */
3358   if (match_dt_element (k, dt) == MATCH_YES)
3359     goto next;
3360   if (match_dt_unit (k, dt) != MATCH_YES)
3361     goto loop;
3362
3363   if (gfc_match_char (')') == MATCH_YES)
3364     goto get_io_list;
3365   if (gfc_match_char (',') != MATCH_YES)
3366     goto syntax;
3367
3368   m = match_dt_element (k, dt);
3369   if (m == MATCH_YES)
3370     goto next;
3371   if (m == MATCH_ERROR)
3372     goto cleanup;
3373
3374   m = match_dt_format (dt);
3375   if (m == MATCH_YES)
3376     goto next;
3377   if (m == MATCH_ERROR)
3378     goto cleanup;
3379
3380   where = gfc_current_locus;
3381
3382   m = gfc_match_name (name);
3383   if (m == MATCH_YES)
3384     {
3385       gfc_find_symbol (name, NULL, 1, &sym);
3386       if (sym && sym->attr.flavor == FL_NAMELIST)
3387         {
3388           dt->namelist = sym;
3389           if (k == M_READ && check_namelist (sym))
3390             {
3391               m = MATCH_ERROR;
3392               goto cleanup;
3393             }
3394           goto next;
3395         }
3396     }
3397
3398   gfc_current_locus = where;
3399
3400   goto loop;                    /* No matches, try regular elements */
3401
3402 next:
3403   if (gfc_match_char (')') == MATCH_YES)
3404     goto get_io_list;
3405   if (gfc_match_char (',') != MATCH_YES)
3406     goto syntax;
3407
3408 loop:
3409   for (;;)
3410     {
3411       m = match_dt_element (k, dt);
3412       if (m == MATCH_NO)
3413         goto syntax;
3414       if (m == MATCH_ERROR)
3415         goto cleanup;
3416
3417       if (gfc_match_char (')') == MATCH_YES)
3418         break;
3419       if (gfc_match_char (',') != MATCH_YES)
3420         goto syntax;
3421     }
3422
3423 get_io_list:
3424
3425   /* Used in check_io_constraints, where no locus is available.  */
3426   spec_end = gfc_current_locus;
3427
3428   /* Optional leading comma (non-standard).  We use a gfc_expr structure here
3429      to save the locus.  This is used later when resolving transfer statements
3430      that might have a format expression without unit number.  */
3431   if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3432     {
3433       dt->extra_comma = gfc_get_expr ();
3434
3435       /* Set the types to something compatible with iokind. This is needed to
3436          get through gfc_free_expr later since iokind really has no Basic Type,
3437          BT, of its own.  */
3438       dt->extra_comma->expr_type = EXPR_CONSTANT;
3439       dt->extra_comma->ts.type = BT_LOGICAL;
3440
3441       /* Save the iokind and locus for later use in resolution.  */
3442       dt->extra_comma->value.iokind = k;
3443       dt->extra_comma->where = gfc_current_locus;
3444     }
3445
3446   io_code = NULL;
3447   if (gfc_match_eos () != MATCH_YES)
3448     {
3449       if (comma_flag && gfc_match_char (',') != MATCH_YES)
3450         {
3451           gfc_error ("Expected comma in I/O list at %C");
3452           m = MATCH_ERROR;
3453           goto cleanup;
3454         }
3455
3456       m = match_io_list (k, &io_code);
3457       if (m == MATCH_ERROR)
3458         goto cleanup;
3459       if (m == MATCH_NO)
3460         goto syntax;
3461     }
3462
3463   /* A full IO statement has been matched.  Check the constraints.  spec_end is
3464      supplied for cases where no locus is supplied.  */
3465   m = check_io_constraints (k, dt, io_code, &spec_end);
3466
3467   if (m == MATCH_ERROR)
3468     goto cleanup;
3469
3470   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3471   new_st.ext.dt = dt;
3472   new_st.block = gfc_get_code ();
3473   new_st.block->op = new_st.op;
3474   new_st.block->next = io_code;
3475
3476   terminate_io (io_code);
3477
3478   return MATCH_YES;
3479
3480 syntax:
3481   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3482   m = MATCH_ERROR;
3483
3484 cleanup:
3485   gfc_free_dt (dt);
3486   return m;
3487 }
3488
3489
3490 match
3491 gfc_match_read (void)
3492 {
3493   return match_io (M_READ);
3494 }
3495
3496
3497 match
3498 gfc_match_write (void)
3499 {
3500   return match_io (M_WRITE);
3501 }
3502
3503
3504 match
3505 gfc_match_print (void)
3506 {
3507   match m;
3508
3509   m = match_io (M_PRINT);
3510   if (m != MATCH_YES)
3511     return m;
3512
3513   if (gfc_pure (NULL))
3514     {
3515       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3516       return MATCH_ERROR;
3517     }
3518
3519   return MATCH_YES;
3520 }
3521
3522
3523 /* Free a gfc_inquire structure.  */
3524
3525 void
3526 gfc_free_inquire (gfc_inquire *inquire)
3527 {
3528
3529   if (inquire == NULL)
3530     return;
3531
3532   gfc_free_expr (inquire->unit);
3533   gfc_free_expr (inquire->file);
3534   gfc_free_expr (inquire->iomsg);
3535   gfc_free_expr (inquire->iostat);
3536   gfc_free_expr (inquire->exist);
3537   gfc_free_expr (inquire->opened);
3538   gfc_free_expr (inquire->number);
3539   gfc_free_expr (inquire->named);
3540   gfc_free_expr (inquire->name);
3541   gfc_free_expr (inquire->access);
3542   gfc_free_expr (inquire->sequential);
3543   gfc_free_expr (inquire->direct);
3544   gfc_free_expr (inquire->form);
3545   gfc_free_expr (inquire->formatted);
3546   gfc_free_expr (inquire->unformatted);
3547   gfc_free_expr (inquire->recl);
3548   gfc_free_expr (inquire->nextrec);
3549   gfc_free_expr (inquire->blank);
3550   gfc_free_expr (inquire->position);
3551   gfc_free_expr (inquire->action);
3552   gfc_free_expr (inquire->read);
3553   gfc_free_expr (inquire->write);
3554   gfc_free_expr (inquire->readwrite);
3555   gfc_free_expr (inquire->delim);
3556   gfc_free_expr (inquire->encoding);
3557   gfc_free_expr (inquire->pad);
3558   gfc_free_expr (inquire->iolength);
3559   gfc_free_expr (inquire->convert);
3560   gfc_free_expr (inquire->strm_pos);
3561   gfc_free_expr (inquire->asynchronous);
3562   gfc_free_expr (inquire->decimal);
3563   gfc_free_expr (inquire->pending);
3564   gfc_free_expr (inquire->id);
3565   gfc_free_expr (inquire->sign);
3566   gfc_free_expr (inquire->size);
3567   gfc_free_expr (inquire->round);
3568   gfc_free (inquire);
3569 }
3570
3571
3572 /* Match an element of an INQUIRE statement.  */
3573
3574 #define RETM   if (m != MATCH_NO) return m;
3575
3576 static match
3577 match_inquire_element (gfc_inquire *inquire)
3578 {
3579   match m;
3580
3581   m = match_etag (&tag_unit, &inquire->unit);
3582   RETM m = match_etag (&tag_file, &inquire->file);
3583   RETM m = match_ltag (&tag_err, &inquire->err);
3584   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3585   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3586   RETM m = match_vtag (&tag_exist, &inquire->exist);
3587   RETM m = match_vtag (&tag_opened, &inquire->opened);
3588   RETM m = match_vtag (&tag_named, &inquire->named);
3589   RETM m = match_vtag (&tag_name, &inquire->name);
3590   RETM m = match_out_tag (&tag_number, &inquire->number);
3591   RETM m = match_vtag (&tag_s_access, &inquire->access);
3592   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3593   RETM m = match_vtag (&tag_direct, &inquire->direct);
3594   RETM m = match_vtag (&tag_s_form, &inquire->form);
3595   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3596   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3597   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3598   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3599   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3600   RETM m = match_vtag (&tag_s_position, &inquire->position);
3601   RETM m = match_vtag (&tag_s_action, &inquire->action);
3602   RETM m = match_vtag (&tag_read, &inquire->read);
3603   RETM m = match_vtag (&tag_write, &inquire->write);
3604   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3605   RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3606   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3607   RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3608   RETM m = match_vtag (&tag_size, &inquire->size);
3609   RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3610   RETM m = match_vtag (&tag_s_round, &inquire->round);
3611   RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3612   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3613   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3614   RETM m = match_vtag (&tag_convert, &inquire->convert);
3615   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3616   RETM m = match_vtag (&tag_pending, &inquire->pending);
3617   RETM m = match_vtag (&tag_id, &inquire->id);
3618   RETM return MATCH_NO;
3619 }
3620
3621 #undef RETM
3622
3623
3624 match
3625 gfc_match_inquire (void)
3626 {
3627   gfc_inquire *inquire;
3628   gfc_code *code;
3629   match m;
3630   locus loc;
3631
3632   m = gfc_match_char ('(');
3633   if (m == MATCH_NO)
3634     return m;
3635
3636   inquire = XCNEW (gfc_inquire);
3637
3638   loc = gfc_current_locus;
3639
3640   m = match_inquire_element (inquire);
3641   if (m == MATCH_ERROR)
3642     goto cleanup;
3643   if (m == MATCH_NO)
3644     {
3645       m = gfc_match_expr (&inquire->unit);
3646       if (m == MATCH_ERROR)
3647         goto cleanup;
3648       if (m == MATCH_NO)
3649         goto syntax;
3650     }
3651
3652   /* See if we have the IOLENGTH form of the inquire statement.  */
3653   if (inquire->iolength != NULL)
3654     {
3655       if (gfc_match_char (')') != MATCH_YES)
3656         goto syntax;
3657
3658       m = match_io_list (M_INQUIRE, &code);
3659       if (m == MATCH_ERROR)
3660         goto cleanup;
3661       if (m == MATCH_NO)
3662         goto syntax;
3663
3664       new_st.op = EXEC_IOLENGTH;
3665       new_st.expr = inquire->iolength;
3666       new_st.ext.inquire = inquire;
3667
3668       if (gfc_pure (NULL))
3669         {
3670           gfc_free_statements (code);
3671           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3672           return MATCH_ERROR;
3673         }
3674
3675       new_st.block = gfc_get_code ();
3676       new_st.block->op = EXEC_IOLENGTH;
3677       terminate_io (code);
3678       new_st.block->next = code;
3679       return MATCH_YES;
3680     }
3681
3682   /* At this point, we have the non-IOLENGTH inquire statement.  */
3683   for (;;)
3684     {
3685       if (gfc_match_char (')') == MATCH_YES)
3686         break;
3687       if (gfc_match_char (',') != MATCH_YES)
3688         goto syntax;
3689
3690       m = match_inquire_element (inquire);
3691       if (m == MATCH_ERROR)
3692         goto cleanup;
3693       if (m == MATCH_NO)
3694         goto syntax;
3695
3696       if (inquire->iolength != NULL)
3697         {
3698           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3699           goto cleanup;
3700         }
3701     }
3702
3703   if (gfc_match_eos () != MATCH_YES)
3704     goto syntax;
3705
3706   if (inquire->unit != NULL && inquire->file != NULL)
3707     {
3708       gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3709                  "UNIT specifiers", &loc);
3710       goto cleanup;
3711     }
3712
3713   if (inquire->unit == NULL && inquire->file == NULL)
3714     {
3715       gfc_error ("INQUIRE statement at %L requires either FILE or "
3716                  "UNIT specifier", &loc);
3717       goto cleanup;
3718     }
3719
3720   if (gfc_pure (NULL))
3721     {
3722       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3723       goto cleanup;
3724     }
3725
3726   if (inquire->id != NULL && inquire->pending == NULL)
3727     {
3728       gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3729                  "the ID= specifier", &loc);
3730       goto cleanup;
3731     }
3732
3733   new_st.op = EXEC_INQUIRE;
3734   new_st.ext.inquire = inquire;
3735   return MATCH_YES;
3736
3737 syntax:
3738   gfc_syntax_error (ST_INQUIRE);
3739
3740 cleanup:
3741   gfc_free_inquire (inquire);
3742   return MATCH_ERROR;
3743 }
3744
3745
3746 /* Resolve everything in a gfc_inquire structure.  */
3747
3748 gfc_try
3749 gfc_resolve_inquire (gfc_inquire *inquire)
3750 {
3751   RESOLVE_TAG (&tag_unit, inquire->unit);
3752   RESOLVE_TAG (&tag_file, inquire->file);
3753   RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
3754   RESOLVE_TAG (&tag_iostat, inquire->iostat);
3755   RESOLVE_TAG (&tag_exist, inquire->exist);
3756   RESOLVE_TAG (&tag_opened, inquire->opened);
3757   RESOLVE_TAG (&tag_number, inquire->number);
3758   RESOLVE_TAG (&tag_named, inquire->named);
3759   RESOLVE_TAG (&tag_name, inquire->name);
3760   RESOLVE_TAG (&tag_s_access, inquire->access);
3761   RESOLVE_TAG (&tag_sequential, inquire->sequential);
3762   RESOLVE_TAG (&tag_direct, inquire->direct);
3763   RESOLVE_TAG (&tag_s_form, inquire->form);
3764   RESOLVE_TAG (&tag_formatted, inquire->formatted);
3765   RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
3766   RESOLVE_TAG (&tag_s_recl, inquire->recl);
3767   RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
3768   RESOLVE_TAG (&tag_s_blank, inquire->blank);
3769   RESOLVE_TAG (&tag_s_position, inquire->position);
3770   RESOLVE_TAG (&tag_s_action, inquire->action);
3771   RESOLVE_TAG (&tag_read, inquire->read);
3772   RESOLVE_TAG (&tag_write, inquire->write);
3773   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
3774   RESOLVE_TAG (&tag_s_delim, inquire->delim);
3775   RESOLVE_TAG (&tag_s_pad, inquire->pad);
3776   RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
3777   RESOLVE_TAG (&tag_s_round, inquire->round);
3778   RESOLVE_TAG (&tag_iolength, inquire->iolength);
3779   RESOLVE_TAG (&tag_convert, inquire->convert);
3780   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
3781   RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
3782   RESOLVE_TAG (&tag_s_sign, inquire->sign);
3783   RESOLVE_TAG (&tag_s_round, inquire->round);
3784   RESOLVE_TAG (&tag_pending, inquire->pending);
3785   RESOLVE_TAG (&tag_size, inquire->size);
3786   RESOLVE_TAG (&tag_id, inquire->id);
3787
3788   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
3789     return FAILURE;
3790
3791   return SUCCESS;
3792 }
3793
3794
3795 void
3796 gfc_free_wait (gfc_wait *wait)
3797 {
3798   if (wait == NULL)
3799     return;
3800
3801   gfc_free_expr (wait->unit);
3802   gfc_free_expr (wait->iostat);
3803   gfc_free_expr (wait->iomsg);
3804   gfc_free_expr (wait->id);
3805 }
3806
3807
3808 gfc_try
3809 gfc_resolve_wait (gfc_wait *wait)
3810 {
3811   RESOLVE_TAG (&tag_unit, wait->unit);
3812   RESOLVE_TAG (&tag_iomsg, wait->iomsg);
3813   RESOLVE_TAG (&tag_iostat, wait->iostat);
3814   RESOLVE_TAG (&tag_id, wait->id);
3815
3816   if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
3817     return FAILURE;
3818
3819   if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
3820     return FAILURE;
3821
3822   return SUCCESS;
3823 }
3824
3825 /* Match an element of a WAIT statement.  */
3826
3827 #define RETM   if (m != MATCH_NO) return m;
3828
3829 static match
3830 match_wait_element (gfc_wait *wait)
3831 {
3832   match m;
3833
3834   m = match_etag (&tag_unit, &wait->unit);
3835   RETM m = match_ltag (&tag_err, &wait->err);
3836   RETM m = match_ltag (&tag_end, &wait->eor);
3837   RETM m = match_ltag (&tag_eor, &wait->end);
3838   RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
3839   RETM m = match_out_tag (&tag_iostat, &wait->iostat);
3840   RETM m = match_etag (&tag_id, &wait->id);
3841   RETM return MATCH_NO;
3842 }
3843
3844 #undef RETM
3845
3846
3847 match
3848 gfc_match_wait (void)
3849 {
3850   gfc_wait *wait;
3851   match m;
3852   locus loc;
3853
3854   m = gfc_match_char ('(');
3855   if (m == MATCH_NO)
3856     return m;
3857
3858   wait = XCNEW (gfc_wait);
3859
3860   loc = gfc_current_locus;
3861
3862   m = match_wait_element (wait);
3863   if (m == MATCH_ERROR)
3864     goto cleanup;
3865   if (m == MATCH_NO)
3866     {
3867       m = gfc_match_expr (&wait->unit);
3868       if (m == MATCH_ERROR)
3869         goto cleanup;
3870       if (m == MATCH_NO)
3871         goto syntax;
3872     }
3873
3874   for (;;)
3875     {
3876       if (gfc_match_char (')') == MATCH_YES)
3877         break;
3878       if (gfc_match_char (',') != MATCH_YES)
3879         goto syntax;
3880
3881       m = match_wait_element (wait);
3882       if (m == MATCH_ERROR)
3883         goto cleanup;
3884       if (m == MATCH_NO)
3885         goto syntax;
3886     }
3887
3888   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
3889           "not allowed in Fortran 95") == FAILURE)
3890     goto cleanup;
3891
3892   if (gfc_pure (NULL))
3893     {
3894       gfc_error ("WAIT statement not allowed in PURE procedure at %C");
3895       goto cleanup;
3896     }
3897
3898   new_st.op = EXEC_WAIT;
3899   new_st.ext.wait = wait;
3900
3901   return MATCH_YES;
3902
3903 syntax:
3904   gfc_syntax_error (ST_WAIT);
3905
3906 cleanup:
3907   gfc_free_wait (wait);
3908   return MATCH_ERROR;
3909 }