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