gcc/fortran/io.c

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