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   if (m == MATCH_YES
 976       && gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
 977     return MATCH_ERROR;
 978
 979   return m;
 980 }
 981
 982
 983 /* Do expression resolution and type-checking on an expression tag.  */
 984
 985 static try
 986 resolve_tag (const io_tag * tag, gfc_expr * e)
 987 {
 988
 989   if (e == NULL)
 990     return SUCCESS;
 991
 992   if (gfc_resolve_expr (e) == FAILURE)
 993     return FAILURE;
 994
 995   if (e->ts.type != tag->type && tag != &tag_format)
 996     {
 997       gfc_error ("%s tag at %L must be of type %s", tag->name,
 998                 &e->where, gfc_basic_typename (tag->type));
 999       return FAILURE;
1000     }
1001
1002   if (tag == &tag_format)
1003     {
1004       if (e->expr_type == EXPR_CONSTANT
1005           && (e->ts.type != BT_CHARACTER
1006               || e->ts.kind != gfc_default_character_kind))
1007         {
1008           gfc_error ("Constant expression in FORMAT tag at %L must be "
1009                      "of type default CHARACTER", &e->where);
1010           return FAILURE;
1011         }
1012
1013       /* If e's rank is zero and e is not an element of an array, it should be
1014          of integer or character type.  The integer variable should be
1015          ASSIGNED.  */
1016       if (e->symtree == NULL || e->symtree->n.sym->as == NULL
1017                 || e->symtree->n.sym->as->rank == 0)
1018         {
1019           if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1020             {
1021               gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
1022                         &e->where, gfc_basic_typename (BT_CHARACTER),
1023                         gfc_basic_typename (BT_INTEGER));
1024               return FAILURE;
1025             }
1026           else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1027             {
1028               if (gfc_notify_std (GFC_STD_F95_DEL,
1029                         "Obsolete: ASSIGNED variable in FORMAT tag at %L",
1030                         &e->where) == FAILURE)
1031                 return FAILURE;
1032               if (e->symtree->n.sym->attr.assign != 1)
1033                 {
1034                   gfc_error ("Variable '%s' at %L has not been assigned a "
1035                         "format label", e->symtree->n.sym->name, &e->where);
1036                   return FAILURE;
1037                 }
1038             }
1039           return SUCCESS;
1040         }
1041       else
1042         {
1043           /* if rank is nonzero, we allow the type to be character under
1044              GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
1045              assigned an Hollerith constant.  */
1046           if (e->ts.type == BT_CHARACTER)
1047             {
1048               if (gfc_notify_std (GFC_STD_GNU,
1049                         "Extension: Character array in FORMAT tag at %L",
1050                         &e->where) == FAILURE)
1051                 return FAILURE;
1052             }
1053           else
1054             {
1055               if (gfc_notify_std (GFC_STD_LEGACY,
1056                         "Extension: Non-character in FORMAT tag at %L",
1057                         &e->where) == FAILURE)
1058                 return FAILURE;
1059             }
1060           return SUCCESS;
1061         }
1062     }
1063   else
1064     {
1065       if (e->rank != 0)
1066         {
1067           gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1068           return FAILURE;
1069         }
1070
1071       if (tag == &tag_iomsg)
1072         {
1073           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1074                               &e->where) == FAILURE)
1075             return FAILURE;
1076         }
1077
1078       if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
1079         {
1080           if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
1081                               "INTEGER in IOSTAT tag at %L",
1082                               &e->where) == FAILURE)
1083             return FAILURE;
1084         }
1085
1086       if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind)
1087         {
1088           if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
1089                               "INTEGER in SIZE tag at %L",
1090                               &e->where) == FAILURE)
1091             return FAILURE;
1092         }
1093
1094       if (tag == &tag_convert)
1095         {
1096           if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1097                               &e->where) == FAILURE)
1098             return FAILURE;
1099         }
1100     }
1101
1102   return SUCCESS;
1103 }
1104
1105
1106 /* Match a single tag of an OPEN statement.  */
1107
1108 static match
1109 match_open_element (gfc_open * open)
1110 {
1111   match m;
1112
1113   m = match_etag (&tag_unit, &open->unit);
1114   if (m != MATCH_NO)
1115     return m;
1116   m = match_out_tag (&tag_iomsg, &open->iomsg);
1117   if (m != MATCH_NO)
1118     return m;
1119   m = match_out_tag (&tag_iostat, &open->iostat);
1120   if (m != MATCH_NO)
1121     return m;
1122   m = match_etag (&tag_file, &open->file);
1123   if (m != MATCH_NO)
1124     return m;
1125   m = match_etag (&tag_status, &open->status);
1126   if (m != MATCH_NO)
1127     return m;
1128   m = match_etag (&tag_e_access, &open->access);
1129   if (m != MATCH_NO)
1130     return m;
1131   m = match_etag (&tag_e_form, &open->form);
1132   if (m != MATCH_NO)
1133     return m;
1134   m = match_etag (&tag_e_recl, &open->recl);
1135   if (m != MATCH_NO)
1136     return m;
1137   m = match_etag (&tag_e_blank, &open->blank);
1138   if (m != MATCH_NO)
1139     return m;
1140   m = match_etag (&tag_e_position, &open->position);
1141   if (m != MATCH_NO)
1142     return m;
1143   m = match_etag (&tag_e_action, &open->action);
1144   if (m != MATCH_NO)
1145     return m;
1146   m = match_etag (&tag_e_delim, &open->delim);
1147   if (m != MATCH_NO)
1148     return m;
1149   m = match_etag (&tag_e_pad, &open->pad);
1150   if (m != MATCH_NO)
1151     return m;
1152   m = match_ltag (&tag_err, &open->err);
1153   if (m != MATCH_NO)
1154     return m;
1155   m = match_etag (&tag_convert, &open->convert);
1156   if (m != MATCH_NO)
1157     return m;
1158
1159   return MATCH_NO;
1160 }
1161
1162
1163 /* Free the gfc_open structure and all the expressions it contains.  */
1164
1165 void
1166 gfc_free_open (gfc_open * open)
1167 {
1168
1169   if (open == NULL)
1170     return;
1171
1172   gfc_free_expr (open->unit);
1173   gfc_free_expr (open->iomsg);
1174   gfc_free_expr (open->iostat);
1175   gfc_free_expr (open->file);
1176   gfc_free_expr (open->status);
1177   gfc_free_expr (open->access);
1178   gfc_free_expr (open->form);
1179   gfc_free_expr (open->recl);
1180   gfc_free_expr (open->blank);
1181   gfc_free_expr (open->position);
1182   gfc_free_expr (open->action);
1183   gfc_free_expr (open->delim);
1184   gfc_free_expr (open->pad);
1185   gfc_free_expr (open->convert);
1186
1187   gfc_free (open);
1188 }
1189
1190
1191 /* Resolve everything in a gfc_open structure.  */
1192
1193 try
1194 gfc_resolve_open (gfc_open * open)
1195 {
1196
1197   RESOLVE_TAG (&tag_unit, open->unit);
1198   RESOLVE_TAG (&tag_iomsg, open->iomsg);
1199   RESOLVE_TAG (&tag_iostat, open->iostat);
1200   RESOLVE_TAG (&tag_file, open->file);
1201   RESOLVE_TAG (&tag_status, open->status);
1202   RESOLVE_TAG (&tag_e_access, open->access);
1203   RESOLVE_TAG (&tag_e_form, open->form);
1204   RESOLVE_TAG (&tag_e_recl, open->recl);
1205
1206   RESOLVE_TAG (&tag_e_blank, open->blank);
1207   RESOLVE_TAG (&tag_e_position, open->position);
1208   RESOLVE_TAG (&tag_e_action, open->action);
1209   RESOLVE_TAG (&tag_e_delim, open->delim);
1210   RESOLVE_TAG (&tag_e_pad, open->pad);
1211   RESOLVE_TAG (&tag_convert, open->convert);
1212
1213   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1214     return FAILURE;
1215
1216   return SUCCESS;
1217 }
1218
1219
1220 /* Match an OPEN statement.  */
1221
1222 match
1223 gfc_match_open (void)
1224 {
1225   gfc_open *open;
1226   match m;
1227
1228   m = gfc_match_char ('(');
1229   if (m == MATCH_NO)
1230     return m;
1231
1232   open = gfc_getmem (sizeof (gfc_open));
1233
1234   m = match_open_element (open);
1235
1236   if (m == MATCH_ERROR)
1237     goto cleanup;
1238   if (m == MATCH_NO)
1239     {
1240       m = gfc_match_expr (&open->unit);
1241       if (m == MATCH_NO)
1242         goto syntax;
1243       if (m == MATCH_ERROR)
1244         goto cleanup;
1245     }
1246
1247   for (;;)
1248     {
1249       if (gfc_match_char (')') == MATCH_YES)
1250         break;
1251       if (gfc_match_char (',') != MATCH_YES)
1252         goto syntax;
1253
1254       m = match_open_element (open);
1255       if (m == MATCH_ERROR)
1256         goto cleanup;
1257       if (m == MATCH_NO)
1258         goto syntax;
1259     }
1260
1261   if (gfc_match_eos () == MATCH_NO)
1262     goto syntax;
1263
1264   if (gfc_pure (NULL))
1265     {
1266       gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1267       goto cleanup;
1268     }
1269
1270   new_st.op = EXEC_OPEN;
1271   new_st.ext.open = open;
1272   return MATCH_YES;
1273
1274 syntax:
1275   gfc_syntax_error (ST_OPEN);
1276
1277 cleanup:
1278   gfc_free_open (open);
1279   return MATCH_ERROR;
1280 }
1281
1282
1283 /* Free a gfc_close structure an all its expressions.  */
1284
1285 void
1286 gfc_free_close (gfc_close * close)
1287 {
1288
1289   if (close == NULL)
1290     return;
1291
1292   gfc_free_expr (close->unit);
1293   gfc_free_expr (close->iomsg);
1294   gfc_free_expr (close->iostat);
1295   gfc_free_expr (close->status);
1296
1297   gfc_free (close);
1298 }
1299
1300
1301 /* Match elements of a CLOSE statement.  */
1302
1303 static match
1304 match_close_element (gfc_close * close)
1305 {
1306   match m;
1307
1308   m = match_etag (&tag_unit, &close->unit);
1309   if (m != MATCH_NO)
1310     return m;
1311   m = match_etag (&tag_status, &close->status);
1312   if (m != MATCH_NO)
1313     return m;
1314   m = match_out_tag (&tag_iomsg, &close->iomsg);
1315   if (m != MATCH_NO)
1316     return m;
1317   m = match_out_tag (&tag_iostat, &close->iostat);
1318   if (m != MATCH_NO)
1319     return m;
1320   m = match_ltag (&tag_err, &close->err);
1321   if (m != MATCH_NO)
1322     return m;
1323
1324   return MATCH_NO;
1325 }
1326
1327
1328 /* Match a CLOSE statement.  */
1329
1330 match
1331 gfc_match_close (void)
1332 {
1333   gfc_close *close;
1334   match m;
1335
1336   m = gfc_match_char ('(');
1337   if (m == MATCH_NO)
1338     return m;
1339
1340   close = gfc_getmem (sizeof (gfc_close));
1341
1342   m = match_close_element (close);
1343
1344   if (m == MATCH_ERROR)
1345     goto cleanup;
1346   if (m == MATCH_NO)
1347     {
1348       m = gfc_match_expr (&close->unit);
1349       if (m == MATCH_NO)
1350         goto syntax;
1351       if (m == MATCH_ERROR)
1352         goto cleanup;
1353     }
1354
1355   for (;;)
1356     {
1357       if (gfc_match_char (')') == MATCH_YES)
1358         break;
1359       if (gfc_match_char (',') != MATCH_YES)
1360         goto syntax;
1361
1362       m = match_close_element (close);
1363       if (m == MATCH_ERROR)
1364         goto cleanup;
1365       if (m == MATCH_NO)
1366         goto syntax;
1367     }
1368
1369   if (gfc_match_eos () == MATCH_NO)
1370     goto syntax;
1371
1372   if (gfc_pure (NULL))
1373     {
1374       gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
1375       goto cleanup;
1376     }
1377
1378   new_st.op = EXEC_CLOSE;
1379   new_st.ext.close = close;
1380   return MATCH_YES;
1381
1382 syntax:
1383   gfc_syntax_error (ST_CLOSE);
1384
1385 cleanup:
1386   gfc_free_close (close);
1387   return MATCH_ERROR;
1388 }
1389
1390
1391 /* Resolve everything in a gfc_close structure.  */
1392
1393 try
1394 gfc_resolve_close (gfc_close * close)
1395 {
1396
1397   RESOLVE_TAG (&tag_unit, close->unit);
1398   RESOLVE_TAG (&tag_iomsg, close->iomsg);
1399   RESOLVE_TAG (&tag_iostat, close->iostat);
1400   RESOLVE_TAG (&tag_status, close->status);
1401
1402   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
1403     return FAILURE;
1404
1405   return SUCCESS;
1406 }
1407
1408
1409 /* Free a gfc_filepos structure.  */
1410
1411 void
1412 gfc_free_filepos (gfc_filepos * fp)
1413 {
1414
1415   gfc_free_expr (fp->unit);
1416   gfc_free_expr (fp->iomsg);
1417   gfc_free_expr (fp->iostat);
1418   gfc_free (fp);
1419 }
1420
1421
1422 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
1423
1424 static match
1425 match_file_element (gfc_filepos * fp)
1426 {
1427   match m;
1428
1429   m = match_etag (&tag_unit, &fp->unit);
1430   if (m != MATCH_NO)
1431     return m;
1432   m = match_out_tag (&tag_iomsg, &fp->iomsg);
1433   if (m != MATCH_NO)
1434     return m;
1435   m = match_out_tag (&tag_iostat, &fp->iostat);
1436   if (m != MATCH_NO)
1437     return m;
1438   m = match_ltag (&tag_err, &fp->err);
1439   if (m != MATCH_NO)
1440     return m;
1441
1442   return MATCH_NO;
1443 }
1444
1445
1446 /* Match the second half of the file-positioning statements, REWIND,
1447    BACKSPACE, ENDFILE, or the FLUSH statement.  */
1448
1449 static match
1450 match_filepos (gfc_statement st, gfc_exec_op op)
1451 {
1452   gfc_filepos *fp;
1453   match m;
1454
1455   fp = gfc_getmem (sizeof (gfc_filepos));
1456
1457   if (gfc_match_char ('(') == MATCH_NO)
1458     {
1459       m = gfc_match_expr (&fp->unit);
1460       if (m == MATCH_ERROR)
1461         goto cleanup;
1462       if (m == MATCH_NO)
1463         goto syntax;
1464
1465       goto done;
1466     }
1467
1468   m = match_file_element (fp);
1469   if (m == MATCH_ERROR)
1470     goto done;
1471   if (m == MATCH_NO)
1472     {
1473       m = gfc_match_expr (&fp->unit);
1474       if (m == MATCH_ERROR)
1475         goto done;
1476       if (m == MATCH_NO)
1477         goto syntax;
1478     }
1479
1480   for (;;)
1481     {
1482       if (gfc_match_char (')') == MATCH_YES)
1483         break;
1484       if (gfc_match_char (',') != MATCH_YES)
1485         goto syntax;
1486
1487       m = match_file_element (fp);
1488       if (m == MATCH_ERROR)
1489         goto cleanup;
1490       if (m == MATCH_NO)
1491         goto syntax;
1492     }
1493
1494 done:
1495   if (gfc_match_eos () != MATCH_YES)
1496     goto syntax;
1497
1498   if (gfc_pure (NULL))
1499     {
1500       gfc_error ("%s statement not allowed in PURE procedure at %C",
1501                  gfc_ascii_statement (st));
1502
1503       goto cleanup;
1504     }
1505
1506   new_st.op = op;
1507   new_st.ext.filepos = fp;
1508   return MATCH_YES;
1509
1510 syntax:
1511   gfc_syntax_error (st);
1512
1513 cleanup:
1514   gfc_free_filepos (fp);
1515   return MATCH_ERROR;
1516 }
1517
1518
1519 try
1520 gfc_resolve_filepos (gfc_filepos * fp)
1521 {
1522
1523   RESOLVE_TAG (&tag_unit, fp->unit);
1524   RESOLVE_TAG (&tag_iostat, fp->iostat);
1525   RESOLVE_TAG (&tag_iomsg, fp->iomsg);
1526   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
1527     return FAILURE;
1528
1529   return SUCCESS;
1530 }
1531
1532
1533 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
1534    and the FLUSH statement.  */
1535
1536 match
1537 gfc_match_endfile (void)
1538 {
1539
1540   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
1541 }
1542
1543 match
1544 gfc_match_backspace (void)
1545 {
1546
1547   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
1548 }
1549
1550 match
1551 gfc_match_rewind (void)
1552 {
1553
1554   return match_filepos (ST_REWIND, EXEC_REWIND);
1555 }
1556
1557 match
1558 gfc_match_flush (void)
1559 {
1560   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C") == FAILURE)
1561     return MATCH_ERROR;
1562
1563   return match_filepos (ST_FLUSH, EXEC_FLUSH);
1564 }
1565
1566 /******************** Data Transfer Statements *********************/
1567
1568 typedef enum
1569 { M_READ, M_WRITE, M_PRINT, M_INQUIRE }
1570 io_kind;
1571
1572
1573 /* Return a default unit number.  */
1574
1575 static gfc_expr *
1576 default_unit (io_kind k)
1577 {
1578   int unit;
1579
1580   if (k == M_READ)
1581     unit = 5;
1582   else
1583     unit = 6;
1584
1585   return gfc_int_expr (unit);
1586 }
1587
1588
1589 /* Match a unit specification for a data transfer statement.  */
1590
1591 static match
1592 match_dt_unit (io_kind k, gfc_dt * dt)
1593 {
1594   gfc_expr *e;
1595
1596   if (gfc_match_char ('*') == MATCH_YES)
1597     {
1598       if (dt->io_unit != NULL)
1599         goto conflict;
1600
1601       dt->io_unit = default_unit (k);
1602       return MATCH_YES;
1603     }
1604
1605   if (gfc_match_expr (&e) == MATCH_YES)
1606     {
1607       if (dt->io_unit != NULL)
1608         {
1609           gfc_free_expr (e);
1610           goto conflict;
1611         }
1612
1613       dt->io_unit = e;
1614       return MATCH_YES;
1615     }
1616
1617   return MATCH_NO;
1618
1619 conflict:
1620   gfc_error ("Duplicate UNIT specification at %C");
1621   return MATCH_ERROR;
1622 }
1623
1624
1625 /* Match a format specification.  */
1626
1627 static match
1628 match_dt_format (gfc_dt * dt)
1629 {
1630   locus where;
1631   gfc_expr *e;
1632   gfc_st_label *label;
1633
1634   where = gfc_current_locus;
1635
1636   if (gfc_match_char ('*') == MATCH_YES)
1637     {
1638       if (dt->format_expr != NULL || dt->format_label != NULL)
1639         goto conflict;
1640
1641       dt->format_label = &format_asterisk;
1642       return MATCH_YES;
1643     }
1644
1645   if (gfc_match_st_label (&label) == MATCH_YES)
1646     {
1647       if (dt->format_expr != NULL || dt->format_label != NULL)
1648         {
1649           gfc_free_st_label (label);
1650           goto conflict;
1651         }
1652
1653       if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
1654         return MATCH_ERROR;
1655
1656       dt->format_label = label;
1657       return MATCH_YES;
1658     }
1659
1660   if (gfc_match_expr (&e) == MATCH_YES)
1661     {
1662       if (dt->format_expr != NULL || dt->format_label != NULL)
1663         {
1664           gfc_free_expr (e);
1665           goto conflict;
1666         }
1667       dt->format_expr = e;
1668       return MATCH_YES;
1669     }
1670
1671   gfc_current_locus = where;    /* The only case where we have to restore */
1672
1673   return MATCH_NO;
1674
1675 conflict:
1676   gfc_error ("Duplicate format specification at %C");
1677   return MATCH_ERROR;
1678 }
1679
1680
1681 /* Traverse a namelist that is part of a READ statement to make sure
1682    that none of the variables in the namelist are INTENT(IN).  Returns
1683    nonzero if we find such a variable.  */
1684
1685 static int
1686 check_namelist (gfc_symbol * sym)
1687 {
1688   gfc_namelist *p;
1689
1690   for (p = sym->namelist; p; p = p->next)
1691     if (p->sym->attr.intent == INTENT_IN)
1692       {
1693         gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
1694                    p->sym->name, sym->name);
1695         return 1;
1696       }
1697
1698   return 0;
1699 }
1700
1701
1702 /* Match a single data transfer element.  */
1703
1704 static match
1705 match_dt_element (io_kind k, gfc_dt * dt)
1706 {
1707   char name[GFC_MAX_SYMBOL_LEN + 1];
1708   gfc_symbol *sym;
1709   match m;
1710
1711   if (gfc_match (" unit =") == MATCH_YES)
1712     {
1713       m = match_dt_unit (k, dt);
1714       if (m != MATCH_NO)
1715         return m;
1716     }
1717
1718   if (gfc_match (" fmt =") == MATCH_YES)
1719     {
1720       m = match_dt_format (dt);
1721       if (m != MATCH_NO)
1722         return m;
1723     }
1724
1725   if (gfc_match (" nml = %n", name) == MATCH_YES)
1726     {
1727       if (dt->namelist != NULL)
1728         {
1729           gfc_error ("Duplicate NML specification at %C");
1730           return MATCH_ERROR;
1731         }
1732
1733       if (gfc_find_symbol (name, NULL, 1, &sym))
1734         return MATCH_ERROR;
1735
1736       if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
1737         {
1738           gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
1739                      sym != NULL ? sym->name : name);
1740           return MATCH_ERROR;
1741         }
1742
1743       dt->namelist = sym;
1744       if (k == M_READ && check_namelist (sym))
1745         return MATCH_ERROR;
1746
1747       return MATCH_YES;
1748     }
1749
1750   m = match_etag (&tag_rec, &dt->rec);
1751   if (m != MATCH_NO)
1752     return m;
1753   m = match_out_tag (&tag_iomsg, &dt->iomsg);
1754   if (m != MATCH_NO)
1755     return m;
1756   m = match_out_tag (&tag_iostat, &dt->iostat);
1757   if (m != MATCH_NO)
1758     return m;
1759   m = match_ltag (&tag_err, &dt->err);
1760   if (m == MATCH_YES)
1761     dt->err_where = gfc_current_locus;
1762   if (m != MATCH_NO)
1763     return m;
1764   m = match_etag (&tag_advance, &dt->advance);
1765   if (m != MATCH_NO)
1766     return m;
1767   m = match_out_tag (&tag_size, &dt->size);
1768   if (m != MATCH_NO)
1769     return m;
1770
1771   m = match_ltag (&tag_end, &dt->end);
1772   if (m == MATCH_YES)
1773     {
1774       if (k == M_WRITE)
1775        {
1776          gfc_error ("END tag at %C not allowed in output statement");
1777          return MATCH_ERROR;
1778        }
1779       dt->end_where = gfc_current_locus;
1780     }
1781   if (m != MATCH_NO)
1782     return m;
1783
1784   m = match_ltag (&tag_eor, &dt->eor);
1785   if (m == MATCH_YES)
1786     dt->eor_where = gfc_current_locus;
1787   if (m != MATCH_NO)
1788     return m;
1789
1790   return MATCH_NO;
1791 }
1792
1793
1794 /* Free a data transfer structure and everything below it.  */
1795
1796 void
1797 gfc_free_dt (gfc_dt * dt)
1798 {
1799
1800   if (dt == NULL)
1801     return;
1802
1803   gfc_free_expr (dt->io_unit);
1804   gfc_free_expr (dt->format_expr);
1805   gfc_free_expr (dt->rec);
1806   gfc_free_expr (dt->advance);
1807   gfc_free_expr (dt->iomsg);
1808   gfc_free_expr (dt->iostat);
1809   gfc_free_expr (dt->size);
1810
1811   gfc_free (dt);
1812 }
1813
1814
1815 /* Resolve everything in a gfc_dt structure.  */
1816
1817 try
1818 gfc_resolve_dt (gfc_dt * dt)
1819 {
1820   gfc_expr *e;
1821
1822   RESOLVE_TAG (&tag_format, dt->format_expr);
1823   RESOLVE_TAG (&tag_rec, dt->rec);
1824   RESOLVE_TAG (&tag_advance, dt->advance);
1825   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
1826   RESOLVE_TAG (&tag_iostat, dt->iostat);
1827   RESOLVE_TAG (&tag_size, dt->size);
1828
1829   e = dt->io_unit;
1830   if (gfc_resolve_expr (e) == SUCCESS
1831       && (e->ts.type != BT_INTEGER
1832           && (e->ts.type != BT_CHARACTER
1833               || e->expr_type != EXPR_VARIABLE)))
1834     {
1835       gfc_error
1836         ("UNIT specification at %L must be an INTEGER expression or a "
1837          "CHARACTER variable", &e->where);
1838       return FAILURE;
1839     }
1840
1841   if (e->ts.type == BT_CHARACTER)
1842     {
1843       if (gfc_has_vector_index (e))
1844         {
1845           gfc_error ("Internal unit with vector subscript at %L",
1846                      &e->where);
1847           return FAILURE;
1848         }
1849     }
1850
1851   if (e->rank && e->ts.type != BT_CHARACTER)
1852     {
1853       gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
1854       return FAILURE;
1855     }
1856
1857   if (dt->err)
1858     {
1859       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
1860         return FAILURE;
1861       if (dt->err->defined == ST_LABEL_UNKNOWN)
1862         {
1863           gfc_error ("ERR tag label %d at %L not defined",
1864                       dt->err->value, &dt->err_where);
1865           return FAILURE;
1866         }
1867     }
1868
1869   if (dt->end)
1870     {
1871       if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
1872         return FAILURE;
1873       if (dt->end->defined == ST_LABEL_UNKNOWN)
1874         {
1875           gfc_error ("END tag label %d at %L not defined",
1876                       dt->end->value, &dt->end_where);
1877           return FAILURE;
1878         }
1879     }
1880
1881   if (dt->eor)
1882     {
1883       if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
1884         return FAILURE;
1885       if (dt->eor->defined == ST_LABEL_UNKNOWN)
1886         {
1887           gfc_error ("EOR tag label %d at %L not defined",
1888                       dt->eor->value, &dt->eor_where);
1889           return FAILURE;
1890         }
1891     }
1892
1893   /* Check the format label actually exists.  */
1894   if (dt->format_label && dt->format_label != &format_asterisk
1895       && dt->format_label->defined == ST_LABEL_UNKNOWN)
1896     {
1897       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
1898                  &dt->format_label->where);
1899       return FAILURE;
1900     }
1901   return SUCCESS;
1902 }
1903
1904
1905 /* Given an io_kind, return its name.  */
1906
1907 static const char *
1908 io_kind_name (io_kind k)
1909 {
1910   const char *name;
1911
1912   switch (k)
1913     {
1914     case M_READ:
1915       name = "READ";
1916       break;
1917     case M_WRITE:
1918       name = "WRITE";
1919       break;
1920     case M_PRINT:
1921       name = "PRINT";
1922       break;
1923     case M_INQUIRE:
1924       name = "INQUIRE";
1925       break;
1926     default:
1927       gfc_internal_error ("io_kind_name(): bad I/O-kind");
1928     }
1929
1930   return name;
1931 }
1932
1933
1934 /* Match an IO iteration statement of the form:
1935
1936    ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
1937
1938    which is equivalent to a single IO element.  This function is
1939    mutually recursive with match_io_element().  */
1940
1941 static match match_io_element (io_kind k, gfc_code **);
1942
1943 static match
1944 match_io_iterator (io_kind k, gfc_code ** result)
1945 {
1946   gfc_code *head, *tail, *new;
1947   gfc_iterator *iter;
1948   locus old_loc;
1949   match m;
1950   int n;
1951
1952   iter = NULL;
1953   head = NULL;
1954   old_loc = gfc_current_locus;
1955
1956   if (gfc_match_char ('(') != MATCH_YES)
1957     return MATCH_NO;
1958
1959   m = match_io_element (k, &head);
1960   tail = head;
1961
1962   if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
1963     {
1964       m = MATCH_NO;
1965       goto cleanup;
1966     }
1967
1968   /* Can't be anything but an IO iterator.  Build a list.  */
1969   iter = gfc_get_iterator ();
1970
1971   for (n = 1;; n++)
1972     {
1973       m = gfc_match_iterator (iter, 0);
1974       if (m == MATCH_ERROR)
1975         goto cleanup;
1976       if (m == MATCH_YES)
1977         {
1978           gfc_check_do_variable (iter->var->symtree);
1979           break;
1980         }
1981
1982       m = match_io_element (k, &new);
1983       if (m == MATCH_ERROR)
1984         goto cleanup;
1985       if (m == MATCH_NO)
1986         {
1987           if (n > 2)
1988             goto syntax;
1989           goto cleanup;
1990         }
1991
1992       tail = gfc_append_code (tail, new);
1993
1994       if (gfc_match_char (',') != MATCH_YES)
1995         {
1996           if (n > 2)
1997             goto syntax;
1998           m = MATCH_NO;
1999           goto cleanup;
2000         }
2001     }
2002
2003   if (gfc_match_char (')') != MATCH_YES)
2004     goto syntax;
2005
2006   new = gfc_get_code ();
2007   new->op = EXEC_DO;
2008   new->ext.iterator = iter;
2009
2010   new->block = gfc_get_code ();
2011   new->block->op = EXEC_DO;
2012   new->block->next = head;
2013
2014   *result = new;
2015   return MATCH_YES;
2016
2017 syntax:
2018   gfc_error ("Syntax error in I/O iterator at %C");
2019   m = MATCH_ERROR;
2020
2021 cleanup:
2022   gfc_free_iterator (iter, 1);
2023   gfc_free_statements (head);
2024   gfc_current_locus = old_loc;
2025   return m;
2026 }
2027
2028
2029 /* Match a single element of an IO list, which is either a single
2030    expression or an IO Iterator.  */
2031
2032 static match
2033 match_io_element (io_kind k, gfc_code ** cpp)
2034 {
2035   gfc_expr *expr;
2036   gfc_code *cp;
2037   match m;
2038
2039   expr = NULL;
2040
2041   m = match_io_iterator (k, cpp);
2042   if (m == MATCH_YES)
2043     return MATCH_YES;
2044
2045   if (k == M_READ)
2046     {
2047       m = gfc_match_variable (&expr, 0);
2048       if (m == MATCH_NO)
2049         gfc_error ("Expected variable in READ statement at %C");
2050     }
2051   else
2052     {
2053       m = gfc_match_expr (&expr);
2054       if (m == MATCH_NO)
2055         gfc_error ("Expected expression in %s statement at %C",
2056                    io_kind_name (k));
2057     }
2058
2059   if (m == MATCH_YES)
2060     switch (k)
2061       {
2062       case M_READ:
2063         if (expr->symtree->n.sym->attr.intent == INTENT_IN)
2064           {
2065             gfc_error
2066               ("Variable '%s' in input list at %C cannot be INTENT(IN)",
2067                expr->symtree->n.sym->name);
2068             m = MATCH_ERROR;
2069           }
2070
2071         if (gfc_pure (NULL)
2072             && gfc_impure_variable (expr->symtree->n.sym)
2073             && current_dt->io_unit->ts.type == BT_CHARACTER)
2074           {
2075             gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
2076                        expr->symtree->n.sym->name);
2077             m = MATCH_ERROR;
2078           }
2079
2080         if (gfc_check_do_variable (expr->symtree))
2081           m = MATCH_ERROR;
2082
2083         break;
2084
2085       case M_WRITE:
2086         if (current_dt->io_unit->ts.type == BT_CHARACTER
2087             && gfc_pure (NULL)
2088             && current_dt->io_unit->expr_type == EXPR_VARIABLE
2089             && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
2090           {
2091             gfc_error
2092               ("Cannot write to internal file unit '%s' at %C inside a "
2093                "PURE procedure", current_dt->io_unit->symtree->n.sym->name);
2094             m = MATCH_ERROR;
2095           }
2096
2097         break;
2098
2099       default:
2100         break;
2101       }
2102
2103   if (m != MATCH_YES)
2104     {
2105       gfc_free_expr (expr);
2106       return MATCH_ERROR;
2107     }
2108
2109   cp = gfc_get_code ();
2110   cp->op = EXEC_TRANSFER;
2111   cp->expr = expr;
2112
2113   *cpp = cp;
2114   return MATCH_YES;
2115 }
2116
2117
2118 /* Match an I/O list, building gfc_code structures as we go.  */
2119
2120 static match
2121 match_io_list (io_kind k, gfc_code ** head_p)
2122 {
2123   gfc_code *head, *tail, *new;
2124   match m;
2125
2126   *head_p = head = tail = NULL;
2127   if (gfc_match_eos () == MATCH_YES)
2128     return MATCH_YES;
2129
2130   for (;;)
2131     {
2132       m = match_io_element (k, &new);
2133       if (m == MATCH_ERROR)
2134         goto cleanup;
2135       if (m == MATCH_NO)
2136         goto syntax;
2137
2138       tail = gfc_append_code (tail, new);
2139       if (head == NULL)
2140         head = new;
2141
2142       if (gfc_match_eos () == MATCH_YES)
2143         break;
2144       if (gfc_match_char (',') != MATCH_YES)
2145         goto syntax;
2146     }
2147
2148   *head_p = head;
2149   return MATCH_YES;
2150
2151 syntax:
2152   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2153
2154 cleanup:
2155   gfc_free_statements (head);
2156   return MATCH_ERROR;
2157 }
2158
2159
2160 /* Attach the data transfer end node.  */
2161
2162 static void
2163 terminate_io (gfc_code * io_code)
2164 {
2165   gfc_code *c;
2166
2167   if (io_code == NULL)
2168     io_code = new_st.block;
2169
2170   c = gfc_get_code ();
2171   c->op = EXEC_DT_END;
2172
2173   /* Point to structure that is already there */
2174   c->ext.dt = new_st.ext.dt;
2175   gfc_append_code (io_code, c);
2176 }
2177
2178
2179 /* Check the constraints for a data transfer statement.  The majority of the
2180    constraints appearing in 9.4 of the standard appear here.  Some are handled
2181    in resolve_tag and others in gfc_resolve_dt.  */
2182
2183 static match
2184 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end)
2185 {
2186 #define io_constraint(condition,msg,arg)\
2187 if (condition) \
2188   {\
2189     gfc_error(msg,arg);\
2190     m = MATCH_ERROR;\
2191   }
2192
2193   match m;
2194   gfc_expr * expr;
2195   gfc_symbol * sym = NULL;
2196
2197   m = MATCH_YES;
2198
2199   expr = dt->io_unit;
2200   if (expr && expr->expr_type == EXPR_VARIABLE
2201         && expr->ts.type == BT_CHARACTER)
2202     {
2203       sym = expr->symtree->n.sym;
2204
2205       io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
2206                      "Internal file at %L must not be INTENT(IN)",
2207                      &expr->where);
2208
2209       io_constraint (gfc_has_vector_index (dt->io_unit),
2210                      "Internal file incompatible with vector subscript at %L",
2211                      &expr->where);
2212
2213       io_constraint (dt->rec != NULL,
2214                      "REC tag at %L is incompatible with internal file",
2215                      &dt->rec->where);
2216
2217       io_constraint (dt->namelist != NULL,
2218                      "Internal file at %L is incompatible with namelist",
2219                      &expr->where);
2220
2221       io_constraint (dt->advance != NULL,
2222                      "ADVANCE tag at %L is incompatible with internal file",
2223                      &dt->advance->where);
2224     }
2225
2226   if (expr && expr->ts.type != BT_CHARACTER)
2227     {
2228
2229       io_constraint (gfc_pure (NULL)
2230                        && (k == M_READ || k == M_WRITE),
2231                      "IO UNIT in %s statement at %C must be "
2232                      "an internal file in a PURE procedure",
2233                      io_kind_name (k));
2234     }
2235
2236
2237   if (k != M_READ)
2238     {
2239       io_constraint (dt->end,
2240                      "END tag not allowed with output at %L",
2241                      &dt->end_where);
2242
2243       io_constraint (dt->eor,
2244                      "EOR tag not allowed with output at %L",
2245                      &dt->eor_where);
2246
2247       io_constraint (k != M_READ && dt->size,
2248                      "SIZE=specifier not allowed with output at %L",
2249                      &dt->size->where);
2250     }
2251   else
2252     {
2253       io_constraint (dt->size && dt->advance == NULL,
2254                      "SIZE tag at %L requires an ADVANCE tag",
2255                      &dt->size->where);
2256
2257       io_constraint (dt->eor && dt->advance == NULL,
2258                      "EOR tag at %L requires an ADVANCE tag",
2259                      &dt->eor_where);
2260     }
2261
2262
2263
2264   if (dt->namelist)
2265     {
2266       io_constraint (io_code && dt->namelist,
2267                      "NAMELIST cannot be followed by IO-list at %L",
2268                      &io_code->loc);
2269
2270       io_constraint (dt->format_expr,
2271                      "IO spec-list cannot contain both NAMELIST group name "
2272                      "and format specification at %L.",
2273                      &dt->format_expr->where);
2274
2275       io_constraint (dt->format_label,
2276                      "IO spec-list cannot contain both NAMELIST group name "
2277                      "and format label at %L", spec_end);
2278
2279       io_constraint (dt->rec,
2280                      "NAMELIST IO is not allowed with a REC=specifier "
2281                      "at %L.", &dt->rec->where);
2282
2283       io_constraint (dt->advance,
2284                      "NAMELIST IO is not allowed with a ADVANCE=specifier "
2285                      "at %L.", &dt->advance->where);
2286     }
2287
2288   if (dt->rec)
2289     {
2290       io_constraint (dt->end,
2291                      "An END tag is not allowed with a "
2292                      "REC=specifier at %L.", &dt->end_where);
2293
2294
2295       io_constraint (dt->format_label == &format_asterisk,
2296                      "FMT=* is not allowed with a REC=specifier "
2297                      "at %L.", spec_end);
2298     }
2299
2300   if (dt->advance)
2301     {
2302       const char * advance;
2303       int not_yes, not_no;
2304       expr = dt->advance;
2305       advance = expr->value.character.string;
2306
2307       io_constraint (dt->format_label == &format_asterisk,
2308                      "List directed format(*) is not allowed with a "
2309                      "ADVANCE=specifier at %L.", &expr->where);
2310
2311       not_no = strncasecmp (advance, "no", 2) != 0;
2312       not_yes = strncasecmp (advance, "yes", 2) != 0;
2313
2314       io_constraint (expr->expr_type == EXPR_CONSTANT
2315                        && not_no && not_yes,
2316                      "ADVANCE=specifier at %L must have value = "
2317                      "YES or NO.", &expr->where);
2318
2319       io_constraint (dt->size && expr->expr_type == EXPR_CONSTANT
2320                        && not_no && k == M_READ,
2321                      "SIZE tag at %L requires an ADVANCE = 'NO'",
2322                      &dt->size->where);
2323
2324       io_constraint (dt->eor && expr->expr_type == EXPR_CONSTANT
2325                        && not_no && k == M_READ,
2326                      "EOR tag at %L requires an ADVANCE = 'NO'",
2327                      &dt->eor_where);
2328     }
2329
2330   expr = dt->format_expr;
2331   if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
2332     check_format_string (expr);
2333
2334   return m;
2335 }
2336 #undef io_constraint
2337
2338 /* Match a READ, WRITE or PRINT statement.  */
2339
2340 static match
2341 match_io (io_kind k)
2342 {
2343   char name[GFC_MAX_SYMBOL_LEN + 1];
2344   gfc_code *io_code;
2345   gfc_symbol *sym;
2346   int comma_flag, c;
2347   locus where;
2348   locus spec_end;
2349   gfc_dt *dt;
2350   match m;
2351
2352   where = gfc_current_locus;
2353   comma_flag = 0;
2354   current_dt = dt = gfc_getmem (sizeof (gfc_dt));
2355   if (gfc_match_char ('(') == MATCH_NO)
2356     {
2357       where = gfc_current_locus;
2358       if (k == M_WRITE)
2359         goto syntax;
2360       else if (k == M_PRINT)
2361         {
2362           /* Treat the non-standard case of PRINT namelist.  */
2363           if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
2364               && gfc_match_name (name) == MATCH_YES)
2365             {
2366               gfc_find_symbol (name, NULL, 1, &sym);
2367               if (sym && sym->attr.flavor == FL_NAMELIST)
2368                 {
2369                   if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
2370                                       "%C is an extension") == FAILURE)
2371                     {
2372                       m = MATCH_ERROR;
2373                       goto cleanup;
2374                     }
2375
2376                   dt->io_unit = default_unit (k);
2377                   dt->namelist = sym;
2378                   goto get_io_list;
2379                 }
2380               else
2381                 gfc_current_locus = where;
2382             }
2383         }
2384
2385       if (gfc_current_form == FORM_FREE)
2386         {
2387           c = gfc_peek_char();
2388           if (c != ' ' && c != '*' && c != '\'' && c != '"')
2389             {
2390               m = MATCH_NO;
2391               goto cleanup;
2392             }
2393         }
2394
2395       m = match_dt_format (dt);
2396       if (m == MATCH_ERROR)
2397         goto cleanup;
2398       if (m == MATCH_NO)
2399         goto syntax;
2400
2401       comma_flag = 1;
2402       dt->io_unit = default_unit (k);
2403       goto get_io_list;
2404     }
2405
2406   /* Match a control list */
2407   if (match_dt_element (k, dt) == MATCH_YES)
2408     goto next;
2409   if (match_dt_unit (k, dt) != MATCH_YES)
2410     goto loop;
2411
2412   if (gfc_match_char (')') == MATCH_YES)
2413     goto get_io_list;
2414   if (gfc_match_char (',') != MATCH_YES)
2415     goto syntax;
2416
2417   m = match_dt_element (k, dt);
2418   if (m == MATCH_YES)
2419     goto next;
2420   if (m == MATCH_ERROR)
2421     goto cleanup;
2422
2423   m = match_dt_format (dt);
2424   if (m == MATCH_YES)
2425     goto next;
2426   if (m == MATCH_ERROR)
2427     goto cleanup;
2428
2429   where = gfc_current_locus;
2430
2431   m = gfc_match_name (name);
2432   if (m == MATCH_YES)
2433     {
2434       gfc_find_symbol (name, NULL, 1, &sym);
2435       if (sym && sym->attr.flavor == FL_NAMELIST)
2436         {
2437           dt->namelist = sym;
2438           if (k == M_READ && check_namelist (sym))
2439             {
2440               m = MATCH_ERROR;
2441               goto cleanup;
2442             }
2443           goto next;
2444         }
2445     }
2446
2447   gfc_current_locus = where;
2448
2449   goto loop;                    /* No matches, try regular elements */
2450
2451 next:
2452   if (gfc_match_char (')') == MATCH_YES)
2453     goto get_io_list;
2454   if (gfc_match_char (',') != MATCH_YES)
2455     goto syntax;
2456
2457 loop:
2458   for (;;)
2459     {
2460       m = match_dt_element (k, dt);
2461       if (m == MATCH_NO)
2462         goto syntax;
2463       if (m == MATCH_ERROR)
2464         goto cleanup;
2465
2466       if (gfc_match_char (')') == MATCH_YES)
2467         break;
2468       if (gfc_match_char (',') != MATCH_YES)
2469         goto syntax;
2470     }
2471
2472 get_io_list:
2473
2474   /* Used in check_io_constraints, where no locus is available.  */
2475   spec_end = gfc_current_locus;
2476
2477   /* Optional leading comma (non-standard).  */
2478   if (!comma_flag
2479       && gfc_match_char (',') == MATCH_YES
2480       && k == M_WRITE
2481       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before output "
2482                          "item list at %C is an extension") == FAILURE)
2483     return MATCH_ERROR;
2484
2485   io_code = NULL;
2486   if (gfc_match_eos () != MATCH_YES)
2487     {
2488       if (comma_flag && gfc_match_char (',') != MATCH_YES)
2489         {
2490           gfc_error ("Expected comma in I/O list at %C");
2491           m = MATCH_ERROR;
2492           goto cleanup;
2493         }
2494
2495       m = match_io_list (k, &io_code);
2496       if (m == MATCH_ERROR)
2497         goto cleanup;
2498       if (m == MATCH_NO)
2499         goto syntax;
2500     }
2501
2502   /* A full IO statement has been matched.  Check the constraints.  spec_end is
2503      supplied for cases where no locus is supplied.  */
2504   m = check_io_constraints (k, dt, io_code, &spec_end);
2505
2506   if (m == MATCH_ERROR)
2507     goto cleanup;
2508
2509   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
2510   new_st.ext.dt = dt;
2511   new_st.block = gfc_get_code ();
2512   new_st.block->op = new_st.op;
2513   new_st.block->next = io_code;
2514
2515   terminate_io (io_code);
2516
2517   return MATCH_YES;
2518
2519 syntax:
2520   gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2521   m = MATCH_ERROR;
2522
2523 cleanup:
2524   gfc_free_dt (dt);
2525   return m;
2526 }
2527
2528
2529 match
2530 gfc_match_read (void)
2531 {
2532   return match_io (M_READ);
2533 }
2534
2535 match
2536 gfc_match_write (void)
2537 {
2538   return match_io (M_WRITE);
2539 }
2540
2541 match
2542 gfc_match_print (void)
2543 {
2544   match m;
2545
2546   m = match_io (M_PRINT);
2547   if (m != MATCH_YES)
2548     return m;
2549
2550   if (gfc_pure (NULL))
2551     {
2552       gfc_error ("PRINT statement at %C not allowed within PURE procedure");
2553       return MATCH_ERROR;
2554     }
2555
2556   return MATCH_YES;
2557 }
2558
2559
2560 /* Free a gfc_inquire structure.  */
2561
2562 void
2563 gfc_free_inquire (gfc_inquire * inquire)
2564 {
2565
2566   if (inquire == NULL)
2567     return;
2568
2569   gfc_free_expr (inquire->unit);
2570   gfc_free_expr (inquire->file);
2571   gfc_free_expr (inquire->iomsg);
2572   gfc_free_expr (inquire->iostat);
2573   gfc_free_expr (inquire->exist);
2574   gfc_free_expr (inquire->opened);
2575   gfc_free_expr (inquire->number);
2576   gfc_free_expr (inquire->named);
2577   gfc_free_expr (inquire->name);
2578   gfc_free_expr (inquire->access);
2579   gfc_free_expr (inquire->sequential);
2580   gfc_free_expr (inquire->direct);
2581   gfc_free_expr (inquire->form);
2582   gfc_free_expr (inquire->formatted);
2583   gfc_free_expr (inquire->unformatted);
2584   gfc_free_expr (inquire->recl);
2585   gfc_free_expr (inquire->nextrec);
2586   gfc_free_expr (inquire->blank);
2587   gfc_free_expr (inquire->position);
2588   gfc_free_expr (inquire->action);
2589   gfc_free_expr (inquire->read);
2590   gfc_free_expr (inquire->write);
2591   gfc_free_expr (inquire->readwrite);
2592   gfc_free_expr (inquire->delim);
2593   gfc_free_expr (inquire->pad);
2594   gfc_free_expr (inquire->iolength);
2595   gfc_free_expr (inquire->convert);
2596
2597   gfc_free (inquire);
2598 }
2599
2600
2601 /* Match an element of an INQUIRE statement.  */
2602
2603 #define RETM   if (m != MATCH_NO) return m;
2604
2605 static match
2606 match_inquire_element (gfc_inquire * inquire)
2607 {
2608   match m;
2609
2610   m = match_etag (&tag_unit, &inquire->unit);
2611   RETM m = match_etag (&tag_file, &inquire->file);
2612   RETM m = match_ltag (&tag_err, &inquire->err);
2613   RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
2614   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
2615   RETM m = match_vtag (&tag_exist, &inquire->exist);
2616   RETM m = match_vtag (&tag_opened, &inquire->opened);
2617   RETM m = match_vtag (&tag_named, &inquire->named);
2618   RETM m = match_vtag (&tag_name, &inquire->name);
2619   RETM m = match_out_tag (&tag_number, &inquire->number);
2620   RETM m = match_vtag (&tag_s_access, &inquire->access);
2621   RETM m = match_vtag (&tag_sequential, &inquire->sequential);
2622   RETM m = match_vtag (&tag_direct, &inquire->direct);
2623   RETM m = match_vtag (&tag_s_form, &inquire->form);
2624   RETM m = match_vtag (&tag_formatted, &inquire->formatted);
2625   RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
2626   RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
2627   RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
2628   RETM m = match_vtag (&tag_s_blank, &inquire->blank);
2629   RETM m = match_vtag (&tag_s_position, &inquire->position);
2630   RETM m = match_vtag (&tag_s_action, &inquire->action);
2631   RETM m = match_vtag (&tag_read, &inquire->read);
2632   RETM m = match_vtag (&tag_write, &inquire->write);
2633   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
2634   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
2635   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
2636   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
2637   RETM m = match_vtag (&tag_convert, &inquire->convert);
2638   RETM return MATCH_NO;
2639 }
2640
2641 #undef RETM
2642
2643
2644 match
2645 gfc_match_inquire (void)
2646 {
2647   gfc_inquire *inquire;
2648   gfc_code *code;
2649   match m;
2650   locus loc;
2651
2652   m = gfc_match_char ('(');
2653   if (m == MATCH_NO)
2654     return m;
2655
2656   inquire = gfc_getmem (sizeof (gfc_inquire));
2657
2658   loc = gfc_current_locus;
2659
2660   m = match_inquire_element (inquire);
2661   if (m == MATCH_ERROR)
2662     goto cleanup;
2663   if (m == MATCH_NO)
2664     {
2665       m = gfc_match_expr (&inquire->unit);
2666       if (m == MATCH_ERROR)
2667         goto cleanup;
2668       if (m == MATCH_NO)
2669         goto syntax;
2670     }
2671
2672   /* See if we have the IOLENGTH form of the inquire statement.  */
2673   if (inquire->iolength != NULL)
2674     {
2675       if (gfc_match_char (')') != MATCH_YES)
2676         goto syntax;
2677
2678       m = match_io_list (M_INQUIRE, &code);
2679       if (m == MATCH_ERROR)
2680         goto cleanup;
2681       if (m == MATCH_NO)
2682         goto syntax;
2683
2684       new_st.op = EXEC_IOLENGTH;
2685       new_st.expr = inquire->iolength;
2686       new_st.ext.inquire = inquire;
2687
2688       if (gfc_pure (NULL))
2689         {
2690           gfc_free_statements (code);
2691           gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2692           return MATCH_ERROR;
2693         }
2694
2695       new_st.block = gfc_get_code ();
2696       new_st.block->op = EXEC_IOLENGTH;
2697       terminate_io (code);
2698       new_st.block->next = code;
2699       return MATCH_YES;
2700     }
2701
2702   /* At this point, we have the non-IOLENGTH inquire statement.  */
2703   for (;;)
2704     {
2705       if (gfc_match_char (')') == MATCH_YES)
2706         break;
2707       if (gfc_match_char (',') != MATCH_YES)
2708         goto syntax;
2709
2710       m = match_inquire_element (inquire);
2711       if (m == MATCH_ERROR)
2712         goto cleanup;
2713       if (m == MATCH_NO)
2714         goto syntax;
2715
2716       if (inquire->iolength != NULL)
2717         {
2718           gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
2719           goto cleanup;
2720         }
2721     }
2722
2723   if (gfc_match_eos () != MATCH_YES)
2724     goto syntax;
2725
2726   if (inquire->unit != NULL && inquire->file != NULL)
2727     {
2728       gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
2729                  " UNIT specifiers", &loc);
2730       goto cleanup;
2731     }
2732
2733   if (inquire->unit == NULL && inquire->file == NULL)
2734     {
2735       gfc_error ("INQUIRE statement at %L requires either FILE or"
2736                      " UNIT specifier", &loc);
2737       goto cleanup;
2738     }
2739
2740   if (gfc_pure (NULL))
2741     {
2742       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2743       goto cleanup;
2744     }
2745
2746   new_st.op = EXEC_INQUIRE;
2747   new_st.ext.inquire = inquire;
2748   return MATCH_YES;
2749
2750 syntax:
2751   gfc_syntax_error (ST_INQUIRE);
2752
2753 cleanup:
2754   gfc_free_inquire (inquire);
2755   return MATCH_ERROR;
2756 }
2757
2758
2759 /* Resolve everything in a gfc_inquire structure.  */
2760
2761 try
2762 gfc_resolve_inquire (gfc_inquire * inquire)
2763 {
2764
2765   RESOLVE_TAG (&tag_unit, inquire->unit);
2766   RESOLVE_TAG (&tag_file, inquire->file);
2767   RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
2768   RESOLVE_TAG (&tag_iostat, inquire->iostat);
2769   RESOLVE_TAG (&tag_exist, inquire->exist);
2770   RESOLVE_TAG (&tag_opened, inquire->opened);
2771   RESOLVE_TAG (&tag_number, inquire->number);
2772   RESOLVE_TAG (&tag_named, inquire->named);
2773   RESOLVE_TAG (&tag_name, inquire->name);
2774   RESOLVE_TAG (&tag_s_access, inquire->access);
2775   RESOLVE_TAG (&tag_sequential, inquire->sequential);
2776   RESOLVE_TAG (&tag_direct, inquire->direct);
2777   RESOLVE_TAG (&tag_s_form, inquire->form);
2778   RESOLVE_TAG (&tag_formatted, inquire->formatted);
2779   RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
2780   RESOLVE_TAG (&tag_s_recl, inquire->recl);
2781   RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
2782   RESOLVE_TAG (&tag_s_blank, inquire->blank);
2783   RESOLVE_TAG (&tag_s_position, inquire->position);
2784   RESOLVE_TAG (&tag_s_action, inquire->action);
2785   RESOLVE_TAG (&tag_read, inquire->read);
2786   RESOLVE_TAG (&tag_write, inquire->write);
2787   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
2788   RESOLVE_TAG (&tag_s_delim, inquire->delim);
2789   RESOLVE_TAG (&tag_s_pad, inquire->pad);
2790   RESOLVE_TAG (&tag_iolength, inquire->iolength);
2791   RESOLVE_TAG (&tag_convert, inquire->convert);
2792
2793   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
2794     return FAILURE;
2795
2796   return SUCCESS;
2797 }