gcc/fortran/io.c

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