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