1/* Deal with I/O statements & related stuff. 2 Copyright (C) 2000-2015 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "flags.h" 25#include "gfortran.h" 26#include "match.h" 27#include "parse.h" 28 29gfc_st_label 30format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 31 0, {NULL, NULL}}; 32 33typedef struct 34{ 35 const char *name, *spec, *value; 36 bt type; 37} 38io_tag; 39 40static const io_tag 41 tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, 42 tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, 43 tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, 44 tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER}, 45 tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER}, 46 tag_e_blank = {"BLANK", " blank =", " %e", BT_CHARACTER}, 47 tag_e_position = {"POSITION", " position =", " %e", BT_CHARACTER}, 48 tag_e_action = {"ACTION", " action =", " %e", BT_CHARACTER}, 49 tag_e_delim = {"DELIM", " delim =", " %e", BT_CHARACTER}, 50 tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER}, 51 tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER}, 52 tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER}, 53 tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER}, 54 tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER}, 55 tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER}, 56 tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER}, 57 tag_advance = {"ADVANCE", " advance =", " %e", BT_CHARACTER}, 58 tag_rec = {"REC", " rec =", " %e", BT_INTEGER}, 59 tag_spos = {"POSITION", " pos =", " %e", BT_INTEGER}, 60 tag_format = {"FORMAT", NULL, NULL, BT_CHARACTER}, 61 tag_iomsg = {"IOMSG", " iomsg =", " %e", BT_CHARACTER}, 62 tag_iostat = {"IOSTAT", " iostat =", " %v", BT_INTEGER}, 63 tag_size = {"SIZE", " size =", " %v", BT_INTEGER}, 64 tag_exist = {"EXIST", " exist =", " %v", BT_LOGICAL}, 65 tag_opened = {"OPENED", " opened =", " %v", BT_LOGICAL}, 66 tag_named = {"NAMED", " named =", " %v", BT_LOGICAL}, 67 tag_name = {"NAME", " name =", " %v", BT_CHARACTER}, 68 tag_number = {"NUMBER", " number =", " %v", BT_INTEGER}, 69 tag_s_access = {"ACCESS", " access =", " %v", BT_CHARACTER}, 70 tag_sequential = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER}, 71 tag_direct = {"DIRECT", " direct =", " %v", BT_CHARACTER}, 72 tag_s_form = {"FORM", " form =", " %v", BT_CHARACTER}, 73 tag_formatted = {"FORMATTED", " formatted =", " %v", BT_CHARACTER}, 74 tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER}, 75 tag_s_recl = {"RECL", " recl =", " %v", BT_INTEGER}, 76 tag_nextrec = {"NEXTREC", " nextrec =", " %v", BT_INTEGER}, 77 tag_s_blank = {"BLANK", " blank =", " %v", BT_CHARACTER}, 78 tag_s_position = {"POSITION", " position =", " %v", BT_CHARACTER}, 79 tag_s_action = {"ACTION", " action =", " %v", BT_CHARACTER}, 80 tag_read = {"READ", " read =", " %v", BT_CHARACTER}, 81 tag_write = {"WRITE", " write =", " %v", BT_CHARACTER}, 82 tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER}, 83 tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER}, 84 tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER}, 85 tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER}, 86 tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER}, 87 tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER}, 88 tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER}, 89 tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER}, 90 tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER}, 91 tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER}, 92 tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER}, 93 tag_err = {"ERR", " err =", " %l", BT_UNKNOWN}, 94 tag_end = {"END", " end =", " %l", BT_UNKNOWN}, 95 tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN}, 96 tag_id = {"ID", " id =", " %v", BT_INTEGER}, 97 tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}, 98 tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER}, 99 tag_s_iqstream = {"STREAM", " stream =", " %v", BT_CHARACTER}; 100 101static gfc_dt *current_dt; 102 103#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false; 104 105 106/**************** Fortran 95 FORMAT parser *****************/ 107 108/* FORMAT tokens returned by format_lex(). */ 109typedef enum 110{ 111 FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, 112 FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, 113 FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, 114 FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, 115 FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC, 116 FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ 117} 118format_token; 119 120/* Local variables for checking format strings. The saved_token is 121 used to back up by a single format token during the parsing 122 process. */ 123static gfc_char_t *format_string; 124static int format_string_pos; 125static int format_length, use_last_char; 126static char error_element; 127static locus format_locus; 128 129static format_token saved_token; 130 131static enum 132{ MODE_STRING, MODE_FORMAT, MODE_COPY } 133mode; 134 135 136/* Return the next character in the format string. */ 137 138static char 139next_char (gfc_instring in_string) 140{ 141 static gfc_char_t c; 142 143 if (use_last_char) 144 { 145 use_last_char = 0; 146 return c; 147 } 148 149 format_length++; 150 151 if (mode == MODE_STRING) 152 c = *format_string++; 153 else 154 { 155 c = gfc_next_char_literal (in_string); 156 if (c == '\n') 157 c = '\0'; 158 } 159 160 if (flag_backslash && c == '\\') 161 { 162 locus old_locus = gfc_current_locus; 163 164 if (gfc_match_special_char (&c) == MATCH_NO) 165 gfc_current_locus = old_locus; 166 167 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) 168 gfc_warning (0, "Extension: backslash character at %C"); 169 } 170 171 if (mode == MODE_COPY) 172 *format_string++ = c; 173 174 if (mode != MODE_STRING) 175 format_locus = gfc_current_locus; 176 177 format_string_pos++; 178 179 c = gfc_wide_toupper (c); 180 return c; 181} 182 183 184/* Back up one character position. Only works once. */ 185 186static void 187unget_char (void) 188{ 189 use_last_char = 1; 190} 191 192/* Eat up the spaces and return a character. */ 193 194static char 195next_char_not_space (bool *error) 196{ 197 char c; 198 do 199 { 200 error_element = c = next_char (NONSTRING); 201 if (c == '\t') 202 { 203 if (gfc_option.allow_std & GFC_STD_GNU) 204 gfc_warning (0, "Extension: Tab character in format at %C"); 205 else 206 { 207 gfc_error ("Extension: Tab character in format at %C"); 208 *error = true; 209 return c; 210 } 211 } 212 } 213 while (gfc_is_whitespace (c)); 214 return c; 215} 216 217static int value = 0; 218 219/* Simple lexical analyzer for getting the next token in a FORMAT 220 statement. */ 221 222static format_token 223format_lex (void) 224{ 225 format_token token; 226 char c, delim; 227 int zflag; 228 int negative_flag; 229 bool error = false; 230 231 if (saved_token != FMT_NONE) 232 { 233 token = saved_token; 234 saved_token = FMT_NONE; 235 return token; 236 } 237 238 c = next_char_not_space (&error); 239 240 negative_flag = 0; 241 switch (c) 242 { 243 case '-': 244 negative_flag = 1; 245 /* Falls through. */ 246 247 case '+': 248 c = next_char_not_space (&error); 249 if (!ISDIGIT (c)) 250 { 251 token = FMT_UNKNOWN; 252 break; 253 } 254 255 value = c - '0'; 256 257 do 258 { 259 c = next_char_not_space (&error); 260 if (ISDIGIT (c)) 261 value = 10 * value + c - '0'; 262 } 263 while (ISDIGIT (c)); 264 265 unget_char (); 266 267 if (negative_flag) 268 value = -value; 269 270 token = FMT_SIGNED_INT; 271 break; 272 273 case '0': 274 case '1': 275 case '2': 276 case '3': 277 case '4': 278 case '5': 279 case '6': 280 case '7': 281 case '8': 282 case '9': 283 zflag = (c == '0'); 284 285 value = c - '0'; 286 287 do 288 { 289 c = next_char_not_space (&error); 290 if (ISDIGIT (c)) 291 { 292 value = 10 * value + c - '0'; 293 if (c != '0') 294 zflag = 0; 295 } 296 } 297 while (ISDIGIT (c)); 298 299 unget_char (); 300 token = zflag ? FMT_ZERO : FMT_POSINT; 301 break; 302 303 case '.': 304 token = FMT_PERIOD; 305 break; 306 307 case ',': 308 token = FMT_COMMA; 309 break; 310 311 case ':': 312 token = FMT_COLON; 313 break; 314 315 case '/': 316 token = FMT_SLASH; 317 break; 318 319 case '$': 320 token = FMT_DOLLAR; 321 break; 322 323 case 'T': 324 c = next_char_not_space (&error); 325 switch (c) 326 { 327 case 'L': 328 token = FMT_TL; 329 break; 330 case 'R': 331 token = FMT_TR; 332 break; 333 default: 334 token = FMT_T; 335 unget_char (); 336 } 337 break; 338 339 case '(': 340 token = FMT_LPAREN; 341 break; 342 343 case ')': 344 token = FMT_RPAREN; 345 break; 346 347 case 'X': 348 token = FMT_X; 349 break; 350 351 case 'S': 352 c = next_char_not_space (&error); 353 if (c != 'P' && c != 'S') 354 unget_char (); 355 356 token = FMT_SIGN; 357 break; 358 359 case 'B': 360 c = next_char_not_space (&error); 361 if (c == 'N' || c == 'Z') 362 token = FMT_BLANK; 363 else 364 { 365 unget_char (); 366 token = FMT_IBOZ; 367 } 368 369 break; 370 371 case '\'': 372 case '"': 373 delim = c; 374 375 value = 0; 376 377 for (;;) 378 { 379 c = next_char (INSTRING_WARN); 380 if (c == '\0') 381 { 382 token = FMT_END; 383 break; 384 } 385 386 if (c == delim) 387 { 388 c = next_char (NONSTRING); 389 390 if (c == '\0') 391 { 392 token = FMT_END; 393 break; 394 } 395 396 if (c != delim) 397 { 398 unget_char (); 399 token = FMT_CHAR; 400 break; 401 } 402 } 403 value++; 404 } 405 break; 406 407 case 'P': 408 token = FMT_P; 409 break; 410 411 case 'I': 412 case 'O': 413 case 'Z': 414 token = FMT_IBOZ; 415 break; 416 417 case 'F': 418 token = FMT_F; 419 break; 420 421 case 'E': 422 c = next_char_not_space (&error); 423 if (c == 'N' ) 424 token = FMT_EN; 425 else if (c == 'S') 426 token = FMT_ES; 427 else 428 { 429 token = FMT_E; 430 unget_char (); 431 } 432 433 break; 434 435 case 'G': 436 token = FMT_G; 437 break; 438 439 case 'H': 440 token = FMT_H; 441 break; 442 443 case 'L': 444 token = FMT_L; 445 break; 446 447 case 'A': 448 token = FMT_A; 449 break; 450 451 case 'D': 452 c = next_char_not_space (&error); 453 if (c == 'P') 454 { 455 if (!gfc_notify_std (GFC_STD_F2003, "DP format " 456 "specifier not allowed at %C")) 457 return FMT_ERROR; 458 token = FMT_DP; 459 } 460 else if (c == 'C') 461 { 462 if (!gfc_notify_std (GFC_STD_F2003, "DC format " 463 "specifier not allowed at %C")) 464 return FMT_ERROR; 465 token = FMT_DC; 466 } 467 else 468 { 469 token = FMT_D; 470 unget_char (); 471 } 472 break; 473 474 case 'R': 475 c = next_char_not_space (&error); 476 switch (c) 477 { 478 case 'C': 479 token = FMT_RC; 480 break; 481 case 'D': 482 token = FMT_RD; 483 break; 484 case 'N': 485 token = FMT_RN; 486 break; 487 case 'P': 488 token = FMT_RP; 489 break; 490 case 'U': 491 token = FMT_RU; 492 break; 493 case 'Z': 494 token = FMT_RZ; 495 break; 496 default: 497 token = FMT_UNKNOWN; 498 unget_char (); 499 break; 500 } 501 break; 502 503 case '\0': 504 token = FMT_END; 505 break; 506 507 case '*': 508 token = FMT_STAR; 509 break; 510 511 default: 512 token = FMT_UNKNOWN; 513 break; 514 } 515 516 if (error) 517 return FMT_ERROR; 518 519 return token; 520} 521 522 523static const char * 524token_to_string (format_token t) 525{ 526 switch (t) 527 { 528 case FMT_D: 529 return "D"; 530 case FMT_G: 531 return "G"; 532 case FMT_E: 533 return "E"; 534 case FMT_EN: 535 return "EN"; 536 case FMT_ES: 537 return "ES"; 538 default: 539 return ""; 540 } 541} 542 543/* Check a format statement. The format string, either from a FORMAT 544 statement or a constant in an I/O statement has already been parsed 545 by itself, and we are checking it for validity. The dual origin 546 means that the warning message is a little less than great. */ 547 548static bool 549check_format (bool is_input) 550{ 551 const char *posint_required = _("Positive width required"); 552 const char *nonneg_required = _("Nonnegative width required"); 553 const char *unexpected_element = _("Unexpected element %<%c%> in format " 554 "string at %L"); 555 const char *unexpected_end = _("Unexpected end of format string"); 556 const char *zero_width = _("Zero width in format descriptor"); 557 558 const char *error; 559 format_token t, u; 560 int level; 561 int repeat; 562 bool rv; 563 564 use_last_char = 0; 565 saved_token = FMT_NONE; 566 level = 0; 567 repeat = 0; 568 rv = true; 569 format_string_pos = 0; 570 571 t = format_lex (); 572 if (t == FMT_ERROR) 573 goto fail; 574 if (t != FMT_LPAREN) 575 { 576 error = _("Missing leading left parenthesis"); 577 goto syntax; 578 } 579 580 t = format_lex (); 581 if (t == FMT_ERROR) 582 goto fail; 583 if (t == FMT_RPAREN) 584 goto finished; /* Empty format is legal */ 585 saved_token = t; 586 587format_item: 588 /* In this state, the next thing has to be a format item. */ 589 t = format_lex (); 590 if (t == FMT_ERROR) 591 goto fail; 592format_item_1: 593 switch (t) 594 { 595 case FMT_STAR: 596 repeat = -1; 597 t = format_lex (); 598 if (t == FMT_ERROR) 599 goto fail; 600 if (t == FMT_LPAREN) 601 { 602 level++; 603 goto format_item; 604 } 605 error = _("Left parenthesis required after %<*%>"); 606 goto syntax; 607 608 case FMT_POSINT: 609 repeat = value; 610 t = format_lex (); 611 if (t == FMT_ERROR) 612 goto fail; 613 if (t == FMT_LPAREN) 614 { 615 level++; 616 goto format_item; 617 } 618 619 if (t == FMT_SLASH) 620 goto optional_comma; 621 622 goto data_desc; 623 624 case FMT_LPAREN: 625 level++; 626 goto format_item; 627 628 case FMT_SIGNED_INT: 629 case FMT_ZERO: 630 /* Signed integer can only precede a P format. */ 631 t = format_lex (); 632 if (t == FMT_ERROR) 633 goto fail; 634 if (t != FMT_P) 635 { 636 error = _("Expected P edit descriptor"); 637 goto syntax; 638 } 639 640 goto data_desc; 641 642 case FMT_P: 643 /* P requires a prior number. */ 644 error = _("P descriptor requires leading scale factor"); 645 goto syntax; 646 647 case FMT_X: 648 /* X requires a prior number if we're being pedantic. */ 649 if (mode != MODE_FORMAT) 650 format_locus.nextc += format_string_pos; 651 if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading " 652 "space count at %L", &format_locus)) 653 return false; 654 goto between_desc; 655 656 case FMT_SIGN: 657 case FMT_BLANK: 658 case FMT_DP: 659 case FMT_DC: 660 case FMT_RC: 661 case FMT_RD: 662 case FMT_RN: 663 case FMT_RP: 664 case FMT_RU: 665 case FMT_RZ: 666 goto between_desc; 667 668 case FMT_CHAR: 669 goto extension_optional_comma; 670 671 case FMT_COLON: 672 case FMT_SLASH: 673 goto optional_comma; 674 675 case FMT_DOLLAR: 676 t = format_lex (); 677 if (t == FMT_ERROR) 678 goto fail; 679 680 if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus)) 681 return false; 682 if (t != FMT_RPAREN || level > 0) 683 { 684 gfc_warning (0, "$ should be the last specifier in format at %L", 685 &format_locus); 686 goto optional_comma_1; 687 } 688 689 goto finished; 690 691 case FMT_T: 692 case FMT_TL: 693 case FMT_TR: 694 case FMT_IBOZ: 695 case FMT_F: 696 case FMT_E: 697 case FMT_EN: 698 case FMT_ES: 699 case FMT_G: 700 case FMT_L: 701 case FMT_A: 702 case FMT_D: 703 case FMT_H: 704 goto data_desc; 705 706 case FMT_END: 707 error = unexpected_end; 708 goto syntax; 709 710 default: 711 error = unexpected_element; 712 goto syntax; 713 } 714 715data_desc: 716 /* In this state, t must currently be a data descriptor. 717 Deal with things that can/must follow the descriptor. */ 718 switch (t) 719 { 720 case FMT_SIGN: 721 case FMT_BLANK: 722 case FMT_DP: 723 case FMT_DC: 724 case FMT_X: 725 break; 726 727 case FMT_P: 728 /* No comma after P allowed only for F, E, EN, ES, D, or G. 729 10.1.1 (1). */ 730 t = format_lex (); 731 if (t == FMT_ERROR) 732 goto fail; 733 if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA 734 && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES 735 && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) 736 { 737 error = _("Comma required after P descriptor"); 738 goto syntax; 739 } 740 if (t != FMT_COMMA) 741 { 742 if (t == FMT_POSINT) 743 { 744 t = format_lex (); 745 if (t == FMT_ERROR) 746 goto fail; 747 } 748 if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D 749 && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) 750 { 751 error = _("Comma required after P descriptor"); 752 goto syntax; 753 } 754 } 755 756 saved_token = t; 757 goto optional_comma; 758 759 case FMT_T: 760 case FMT_TL: 761 case FMT_TR: 762 t = format_lex (); 763 if (t != FMT_POSINT) 764 { 765 error = _("Positive width required with T descriptor"); 766 goto syntax; 767 } 768 break; 769 770 case FMT_L: 771 t = format_lex (); 772 if (t == FMT_ERROR) 773 goto fail; 774 if (t == FMT_POSINT) 775 break; 776 777 switch (gfc_notification_std (GFC_STD_GNU)) 778 { 779 case WARNING: 780 if (mode != MODE_FORMAT) 781 format_locus.nextc += format_string_pos; 782 gfc_warning (0, "Extension: Missing positive width after L " 783 "descriptor at %L", &format_locus); 784 saved_token = t; 785 break; 786 787 case ERROR: 788 error = posint_required; 789 goto syntax; 790 791 case SILENT: 792 saved_token = t; 793 break; 794 795 default: 796 gcc_unreachable (); 797 } 798 break; 799 800 case FMT_A: 801 t = format_lex (); 802 if (t == FMT_ERROR) 803 goto fail; 804 if (t == FMT_ZERO) 805 { 806 error = zero_width; 807 goto syntax; 808 } 809 if (t != FMT_POSINT) 810 saved_token = t; 811 break; 812 813 case FMT_D: 814 case FMT_E: 815 case FMT_G: 816 case FMT_EN: 817 case FMT_ES: 818 u = format_lex (); 819 if (t == FMT_G && u == FMT_ZERO) 820 { 821 if (is_input) 822 { 823 error = zero_width; 824 goto syntax; 825 } 826 if (!gfc_notify_std (GFC_STD_F2008, "%<G0%> in format at %L", 827 &format_locus)) 828 return false; 829 u = format_lex (); 830 if (u != FMT_PERIOD) 831 { 832 saved_token = u; 833 break; 834 } 835 u = format_lex (); 836 if (u != FMT_POSINT) 837 { 838 error = posint_required; 839 goto syntax; 840 } 841 u = format_lex (); 842 if (u == FMT_E) 843 { 844 error = _("E specifier not allowed with g0 descriptor"); 845 goto syntax; 846 } 847 saved_token = u; 848 break; 849 } 850 851 if (u != FMT_POSINT) 852 { 853 format_locus.nextc += format_string_pos; 854 gfc_error ("Positive width required in format " 855 "specifier %s at %L", token_to_string (t), 856 &format_locus); 857 saved_token = u; 858 goto fail; 859 } 860 861 u = format_lex (); 862 if (u == FMT_ERROR) 863 goto fail; 864 if (u != FMT_PERIOD) 865 { 866 /* Warn if -std=legacy, otherwise error. */ 867 format_locus.nextc += format_string_pos; 868 if (gfc_option.warn_std != 0) 869 { 870 gfc_error ("Period required in format " 871 "specifier %s at %L", token_to_string (t), 872 &format_locus); 873 saved_token = u; 874 goto fail; 875 } 876 else 877 gfc_warning (0, "Period required in format " 878 "specifier %s at %L", token_to_string (t), 879 &format_locus); 880 /* If we go to finished, we need to unwind this 881 before the next round. */ 882 format_locus.nextc -= format_string_pos; 883 saved_token = u; 884 break; 885 } 886 887 u = format_lex (); 888 if (u == FMT_ERROR) 889 goto fail; 890 if (u != FMT_ZERO && u != FMT_POSINT) 891 { 892 error = nonneg_required; 893 goto syntax; 894 } 895 896 if (t == FMT_D) 897 break; 898 899 /* Look for optional exponent. */ 900 u = format_lex (); 901 if (u == FMT_ERROR) 902 goto fail; 903 if (u != FMT_E) 904 { 905 saved_token = u; 906 } 907 else 908 { 909 u = format_lex (); 910 if (u == FMT_ERROR) 911 goto fail; 912 if (u != FMT_POSINT) 913 { 914 error = _("Positive exponent width required"); 915 goto syntax; 916 } 917 } 918 919 break; 920 921 case FMT_F: 922 t = format_lex (); 923 if (t == FMT_ERROR) 924 goto fail; 925 if (t != FMT_ZERO && t != FMT_POSINT) 926 { 927 error = nonneg_required; 928 goto syntax; 929 } 930 else if (is_input && t == FMT_ZERO) 931 { 932 error = posint_required; 933 goto syntax; 934 } 935 936 t = format_lex (); 937 if (t == FMT_ERROR) 938 goto fail; 939 if (t != FMT_PERIOD) 940 { 941 /* Warn if -std=legacy, otherwise error. */ 942 if (gfc_option.warn_std != 0) 943 { 944 error = _("Period required in format specifier"); 945 goto syntax; 946 } 947 if (mode != MODE_FORMAT) 948 format_locus.nextc += format_string_pos; 949 gfc_warning (0, "Period required in format specifier at %L", 950 &format_locus); 951 saved_token = t; 952 break; 953 } 954 955 t = format_lex (); 956 if (t == FMT_ERROR) 957 goto fail; 958 if (t != FMT_ZERO && t != FMT_POSINT) 959 { 960 error = nonneg_required; 961 goto syntax; 962 } 963 964 break; 965 966 case FMT_H: 967 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) 968 { 969 if (mode != MODE_FORMAT) 970 format_locus.nextc += format_string_pos; 971 gfc_warning (0, "The H format specifier at %L is" 972 " a Fortran 95 deleted feature", &format_locus); 973 } 974 if (mode == MODE_STRING) 975 { 976 format_string += value; 977 format_length -= value; 978 format_string_pos += repeat; 979 } 980 else 981 { 982 while (repeat >0) 983 { 984 next_char (INSTRING_WARN); 985 repeat -- ; 986 } 987 } 988 break; 989 990 case FMT_IBOZ: 991 t = format_lex (); 992 if (t == FMT_ERROR) 993 goto fail; 994 if (t != FMT_ZERO && t != FMT_POSINT) 995 { 996 error = nonneg_required; 997 goto syntax; 998 } 999 else if (is_input && t == FMT_ZERO) 1000 { 1001 error = posint_required; 1002 goto syntax; 1003 } 1004 1005 t = format_lex (); 1006 if (t == FMT_ERROR) 1007 goto fail; 1008 if (t != FMT_PERIOD) 1009 { 1010 saved_token = t; 1011 } 1012 else 1013 { 1014 t = format_lex (); 1015 if (t == FMT_ERROR) 1016 goto fail; 1017 if (t != FMT_ZERO && t != FMT_POSINT) 1018 { 1019 error = nonneg_required; 1020 goto syntax; 1021 } 1022 } 1023 1024 break; 1025 1026 default: 1027 error = unexpected_element; 1028 goto syntax; 1029 } 1030 1031between_desc: 1032 /* Between a descriptor and what comes next. */ 1033 t = format_lex (); 1034 if (t == FMT_ERROR) 1035 goto fail; 1036 switch (t) 1037 { 1038 1039 case FMT_COMMA: 1040 goto format_item; 1041 1042 case FMT_RPAREN: 1043 level--; 1044 if (level < 0) 1045 goto finished; 1046 goto between_desc; 1047 1048 case FMT_COLON: 1049 case FMT_SLASH: 1050 goto optional_comma; 1051 1052 case FMT_END: 1053 error = unexpected_end; 1054 goto syntax; 1055 1056 default: 1057 if (mode != MODE_FORMAT) 1058 format_locus.nextc += format_string_pos - 1; 1059 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) 1060 return false; 1061 /* If we do not actually return a failure, we need to unwind this 1062 before the next round. */ 1063 if (mode != MODE_FORMAT) 1064 format_locus.nextc -= format_string_pos; 1065 goto format_item_1; 1066 } 1067 1068optional_comma: 1069 /* Optional comma is a weird between state where we've just finished 1070 reading a colon, slash, dollar or P descriptor. */ 1071 t = format_lex (); 1072 if (t == FMT_ERROR) 1073 goto fail; 1074optional_comma_1: 1075 switch (t) 1076 { 1077 case FMT_COMMA: 1078 break; 1079 1080 case FMT_RPAREN: 1081 level--; 1082 if (level < 0) 1083 goto finished; 1084 goto between_desc; 1085 1086 default: 1087 /* Assume that we have another format item. */ 1088 saved_token = t; 1089 break; 1090 } 1091 1092 goto format_item; 1093 1094extension_optional_comma: 1095 /* As a GNU extension, permit a missing comma after a string literal. */ 1096 t = format_lex (); 1097 if (t == FMT_ERROR) 1098 goto fail; 1099 switch (t) 1100 { 1101 case FMT_COMMA: 1102 break; 1103 1104 case FMT_RPAREN: 1105 level--; 1106 if (level < 0) 1107 goto finished; 1108 goto between_desc; 1109 1110 case FMT_COLON: 1111 case FMT_SLASH: 1112 goto optional_comma; 1113 1114 case FMT_END: 1115 error = unexpected_end; 1116 goto syntax; 1117 1118 default: 1119 if (mode != MODE_FORMAT) 1120 format_locus.nextc += format_string_pos; 1121 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) 1122 return false; 1123 /* If we do not actually return a failure, we need to unwind this 1124 before the next round. */ 1125 if (mode != MODE_FORMAT) 1126 format_locus.nextc -= format_string_pos; 1127 saved_token = t; 1128 break; 1129 } 1130 1131 goto format_item; 1132 1133syntax: 1134 if (mode != MODE_FORMAT) 1135 format_locus.nextc += format_string_pos; 1136 if (error == unexpected_element) 1137 gfc_error (error, error_element, &format_locus); 1138 else 1139 gfc_error ("%s in format string at %L", error, &format_locus); 1140fail: 1141 rv = false; 1142 1143finished: 1144 return rv; 1145} 1146 1147 1148/* Given an expression node that is a constant string, see if it looks 1149 like a format string. */ 1150 1151static bool 1152check_format_string (gfc_expr *e, bool is_input) 1153{ 1154 bool rv; 1155 int i; 1156 if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) 1157 return true; 1158 1159 mode = MODE_STRING; 1160 format_string = e->value.character.string; 1161 1162 /* More elaborate measures are needed to show where a problem is within a 1163 format string that has been calculated, but that's probably not worth the 1164 effort. */ 1165 format_locus = e->where; 1166 rv = check_format (is_input); 1167 /* check for extraneous characters at the end of an otherwise valid format 1168 string, like '(A10,I3)F5' 1169 start at the end and move back to the last character processed, 1170 spaces are OK */ 1171 if (rv && e->value.character.length > format_string_pos) 1172 for (i=e->value.character.length-1;i>format_string_pos-1;i--) 1173 if (e->value.character.string[i] != ' ') 1174 { 1175 format_locus.nextc += format_length + 1; 1176 gfc_warning (0, 1177 "Extraneous characters in format at %L", &format_locus); 1178 break; 1179 } 1180 return rv; 1181} 1182 1183 1184/************ Fortran I/O statement matchers *************/ 1185 1186/* Match a FORMAT statement. This amounts to actually parsing the 1187 format descriptors in order to correctly locate the end of the 1188 format string. */ 1189 1190match 1191gfc_match_format (void) 1192{ 1193 gfc_expr *e; 1194 locus start; 1195 1196 if (gfc_current_ns->proc_name 1197 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) 1198 { 1199 gfc_error ("Format statement in module main block at %C"); 1200 return MATCH_ERROR; 1201 } 1202 1203 /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */ 1204 if ((gfc_current_state () == COMP_FUNCTION 1205 || gfc_current_state () == COMP_SUBROUTINE) 1206 && gfc_state_stack->previous->state == COMP_INTERFACE) 1207 { 1208 gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE"); 1209 return MATCH_ERROR; 1210 } 1211 1212 if (gfc_statement_label == NULL) 1213 { 1214 gfc_error ("Missing format label at %C"); 1215 return MATCH_ERROR; 1216 } 1217 gfc_gobble_whitespace (); 1218 1219 mode = MODE_FORMAT; 1220 format_length = 0; 1221 1222 start = gfc_current_locus; 1223 1224 if (!check_format (false)) 1225 return MATCH_ERROR; 1226 1227 if (gfc_match_eos () != MATCH_YES) 1228 { 1229 gfc_syntax_error (ST_FORMAT); 1230 return MATCH_ERROR; 1231 } 1232 1233 /* The label doesn't get created until after the statement is done 1234 being matched, so we have to leave the string for later. */ 1235 1236 gfc_current_locus = start; /* Back to the beginning */ 1237 1238 new_st.loc = start; 1239 new_st.op = EXEC_NOP; 1240 1241 e = gfc_get_character_expr (gfc_default_character_kind, &start, 1242 NULL, format_length); 1243 format_string = e->value.character.string; 1244 gfc_statement_label->format = e; 1245 1246 mode = MODE_COPY; 1247 check_format (false); /* Guaranteed to succeed */ 1248 gfc_match_eos (); /* Guaranteed to succeed */ 1249 1250 return MATCH_YES; 1251} 1252 1253 1254/* Check for a CHARACTER variable. The check for scalar is done in 1255 resolve_tag. */ 1256 1257static bool 1258check_char_variable (gfc_expr *e) 1259{ 1260 if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER) 1261 { 1262 gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where); 1263 return false; 1264 } 1265 return true; 1266} 1267 1268 1269static bool 1270is_char_type (const char *name, gfc_expr *e) 1271{ 1272 gfc_resolve_expr (e); 1273 1274 if (e->ts.type != BT_CHARACTER) 1275 { 1276 gfc_error ("%s requires a scalar-default-char-expr at %L", 1277 name, &e->where); 1278 return false; 1279 } 1280 return true; 1281} 1282 1283 1284/* Match an expression I/O tag of some sort. */ 1285 1286static match 1287match_etag (const io_tag *tag, gfc_expr **v) 1288{ 1289 gfc_expr *result; 1290 match m; 1291 1292 m = gfc_match (tag->spec); 1293 if (m != MATCH_YES) 1294 return m; 1295 1296 m = gfc_match (tag->value, &result); 1297 if (m != MATCH_YES) 1298 { 1299 gfc_error ("Invalid value for %s specification at %C", tag->name); 1300 return MATCH_ERROR; 1301 } 1302 1303 if (*v != NULL) 1304 { 1305 gfc_error ("Duplicate %s specification at %C", tag->name); 1306 gfc_free_expr (result); 1307 return MATCH_ERROR; 1308 } 1309 1310 *v = result; 1311 return MATCH_YES; 1312} 1313 1314 1315/* Match a variable I/O tag of some sort. */ 1316 1317static match 1318match_vtag (const io_tag *tag, gfc_expr **v) 1319{ 1320 gfc_expr *result; 1321 match m; 1322 1323 m = gfc_match (tag->spec); 1324 if (m != MATCH_YES) 1325 return m; 1326 1327 m = gfc_match (tag->value, &result); 1328 if (m != MATCH_YES) 1329 { 1330 gfc_error ("Invalid value for %s specification at %C", tag->name); 1331 return MATCH_ERROR; 1332 } 1333 1334 if (*v != NULL) 1335 { 1336 gfc_error ("Duplicate %s specification at %C", tag->name); 1337 gfc_free_expr (result); 1338 return MATCH_ERROR; 1339 } 1340 1341 if (result->symtree->n.sym->attr.intent == INTENT_IN) 1342 { 1343 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name); 1344 gfc_free_expr (result); 1345 return MATCH_ERROR; 1346 } 1347 1348 bool impure = gfc_impure_variable (result->symtree->n.sym); 1349 if (impure && gfc_pure (NULL)) 1350 { 1351 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C", 1352 tag->name); 1353 gfc_free_expr (result); 1354 return MATCH_ERROR; 1355 } 1356 1357 if (impure) 1358 gfc_unset_implicit_pure (NULL); 1359 1360 *v = result; 1361 return MATCH_YES; 1362} 1363 1364 1365/* Match I/O tags that cause variables to become redefined. */ 1366 1367static match 1368match_out_tag (const io_tag *tag, gfc_expr **result) 1369{ 1370 match m; 1371 1372 m = match_vtag (tag, result); 1373 if (m == MATCH_YES) 1374 gfc_check_do_variable ((*result)->symtree); 1375 1376 return m; 1377} 1378 1379 1380/* Match a label I/O tag. */ 1381 1382static match 1383match_ltag (const io_tag *tag, gfc_st_label ** label) 1384{ 1385 match m; 1386 gfc_st_label *old; 1387 1388 old = *label; 1389 m = gfc_match (tag->spec); 1390 if (m != MATCH_YES) 1391 return m; 1392 1393 m = gfc_match (tag->value, label); 1394 if (m != MATCH_YES) 1395 { 1396 gfc_error ("Invalid value for %s specification at %C", tag->name); 1397 return MATCH_ERROR; 1398 } 1399 1400 if (old) 1401 { 1402 gfc_error ("Duplicate %s label specification at %C", tag->name); 1403 return MATCH_ERROR; 1404 } 1405 1406 if (!gfc_reference_st_label (*label, ST_LABEL_TARGET)) 1407 return MATCH_ERROR; 1408 1409 return m; 1410} 1411 1412 1413/* Resolution of the FORMAT tag, to be called from resolve_tag. */ 1414 1415static bool 1416resolve_tag_format (const gfc_expr *e) 1417{ 1418 if (e->expr_type == EXPR_CONSTANT 1419 && (e->ts.type != BT_CHARACTER 1420 || e->ts.kind != gfc_default_character_kind)) 1421 { 1422 gfc_error ("Constant expression in FORMAT tag at %L must be " 1423 "of type default CHARACTER", &e->where); 1424 return false; 1425 } 1426 1427 /* If e's rank is zero and e is not an element of an array, it should be 1428 of integer or character type. The integer variable should be 1429 ASSIGNED. */ 1430 if (e->rank == 0 1431 && (e->expr_type != EXPR_VARIABLE 1432 || e->symtree == NULL 1433 || e->symtree->n.sym->as == NULL 1434 || e->symtree->n.sym->as->rank == 0)) 1435 { 1436 if ((e->ts.type != BT_CHARACTER 1437 || e->ts.kind != gfc_default_character_kind) 1438 && e->ts.type != BT_INTEGER) 1439 { 1440 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER " 1441 "or of INTEGER", &e->where); 1442 return false; 1443 } 1444 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) 1445 { 1446 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in " 1447 "FORMAT tag at %L", &e->where)) 1448 return false; 1449 if (e->symtree->n.sym->attr.assign != 1) 1450 { 1451 gfc_error ("Variable %qs at %L has not been assigned a " 1452 "format label", e->symtree->n.sym->name, &e->where); 1453 return false; 1454 } 1455 } 1456 else if (e->ts.type == BT_INTEGER) 1457 { 1458 gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED " 1459 "variable", gfc_basic_typename (e->ts.type), &e->where); 1460 return false; 1461 } 1462 1463 return true; 1464 } 1465 1466 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY. 1467 It may be assigned an Hollerith constant. */ 1468 if (e->ts.type != BT_CHARACTER) 1469 { 1470 if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag " 1471 "at %L", &e->where)) 1472 return false; 1473 1474 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) 1475 { 1476 gfc_error ("Non-character assumed shape array element in FORMAT" 1477 " tag at %L", &e->where); 1478 return false; 1479 } 1480 1481 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) 1482 { 1483 gfc_error ("Non-character assumed size array element in FORMAT" 1484 " tag at %L", &e->where); 1485 return false; 1486 } 1487 1488 if (e->rank == 0 && e->symtree->n.sym->attr.pointer) 1489 { 1490 gfc_error ("Non-character pointer array element in FORMAT tag at %L", 1491 &e->where); 1492 return false; 1493 } 1494 } 1495 1496 return true; 1497} 1498 1499 1500/* Do expression resolution and type-checking on an expression tag. */ 1501 1502static bool 1503resolve_tag (const io_tag *tag, gfc_expr *e) 1504{ 1505 if (e == NULL) 1506 return true; 1507 1508 if (!gfc_resolve_expr (e)) 1509 return false; 1510 1511 if (tag == &tag_format) 1512 return resolve_tag_format (e); 1513 1514 if (e->ts.type != tag->type) 1515 { 1516 gfc_error ("%s tag at %L must be of type %s", tag->name, 1517 &e->where, gfc_basic_typename (tag->type)); 1518 return false; 1519 } 1520 1521 if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind) 1522 { 1523 gfc_error ("%s tag at %L must be a character string of default kind", 1524 tag->name, &e->where); 1525 return false; 1526 } 1527 1528 if (e->rank != 0) 1529 { 1530 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); 1531 return false; 1532 } 1533 1534 if (tag == &tag_iomsg) 1535 { 1536 if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where)) 1537 return false; 1538 } 1539 1540 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength 1541 || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl) 1542 && e->ts.kind != gfc_default_integer_kind) 1543 { 1544 if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " 1545 "INTEGER in %s tag at %L", tag->name, &e->where)) 1546 return false; 1547 } 1548 1549 if (e->ts.kind != gfc_default_logical_kind && 1550 (tag == &tag_exist || tag == &tag_named || tag == &tag_opened 1551 || tag == &tag_pending)) 1552 { 1553 if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind " 1554 "in %s tag at %L", tag->name, &e->where)) 1555 return false; 1556 } 1557 1558 if (tag == &tag_newunit) 1559 { 1560 if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L", 1561 &e->where)) 1562 return false; 1563 } 1564 1565 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */ 1566 if (tag == &tag_newunit || tag == &tag_iostat 1567 || tag == &tag_size || tag == &tag_iomsg) 1568 { 1569 char context[64]; 1570 1571 sprintf (context, _("%s tag"), tag->name); 1572 if (!gfc_check_vardef_context (e, false, false, false, context)) 1573 return false; 1574 } 1575 1576 if (tag == &tag_convert) 1577 { 1578 if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where)) 1579 return false; 1580 } 1581 1582 return true; 1583} 1584 1585 1586/* Match a single tag of an OPEN statement. */ 1587 1588static match 1589match_open_element (gfc_open *open) 1590{ 1591 match m; 1592 1593 m = match_etag (&tag_e_async, &open->asynchronous); 1594 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", open->asynchronous)) 1595 return MATCH_ERROR; 1596 if (m != MATCH_NO) 1597 return m; 1598 m = match_etag (&tag_unit, &open->unit); 1599 if (m != MATCH_NO) 1600 return m; 1601 m = match_etag (&tag_iomsg, &open->iomsg); 1602 if (m == MATCH_YES && !check_char_variable (open->iomsg)) 1603 return MATCH_ERROR; 1604 if (m != MATCH_NO) 1605 return m; 1606 m = match_out_tag (&tag_iostat, &open->iostat); 1607 if (m != MATCH_NO) 1608 return m; 1609 m = match_etag (&tag_file, &open->file); 1610 if (m != MATCH_NO) 1611 return m; 1612 m = match_etag (&tag_status, &open->status); 1613 if (m != MATCH_NO) 1614 return m; 1615 m = match_etag (&tag_e_access, &open->access); 1616 if (m != MATCH_NO) 1617 return m; 1618 m = match_etag (&tag_e_form, &open->form); 1619 if (m != MATCH_NO) 1620 return m; 1621 m = match_etag (&tag_e_recl, &open->recl); 1622 if (m != MATCH_NO) 1623 return m; 1624 m = match_etag (&tag_e_blank, &open->blank); 1625 if (m != MATCH_NO) 1626 return m; 1627 m = match_etag (&tag_e_position, &open->position); 1628 if (m != MATCH_NO) 1629 return m; 1630 m = match_etag (&tag_e_action, &open->action); 1631 if (m != MATCH_NO) 1632 return m; 1633 m = match_etag (&tag_e_delim, &open->delim); 1634 if (m != MATCH_NO) 1635 return m; 1636 m = match_etag (&tag_e_pad, &open->pad); 1637 if (m != MATCH_NO) 1638 return m; 1639 m = match_etag (&tag_e_decimal, &open->decimal); 1640 if (m != MATCH_NO) 1641 return m; 1642 m = match_etag (&tag_e_encoding, &open->encoding); 1643 if (m != MATCH_NO) 1644 return m; 1645 m = match_etag (&tag_e_round, &open->round); 1646 if (m != MATCH_NO) 1647 return m; 1648 m = match_etag (&tag_e_sign, &open->sign); 1649 if (m != MATCH_NO) 1650 return m; 1651 m = match_ltag (&tag_err, &open->err); 1652 if (m != MATCH_NO) 1653 return m; 1654 m = match_etag (&tag_convert, &open->convert); 1655 if (m != MATCH_NO) 1656 return m; 1657 m = match_out_tag (&tag_newunit, &open->newunit); 1658 if (m != MATCH_NO) 1659 return m; 1660 1661 return MATCH_NO; 1662} 1663 1664 1665/* Free the gfc_open structure and all the expressions it contains. */ 1666 1667void 1668gfc_free_open (gfc_open *open) 1669{ 1670 if (open == NULL) 1671 return; 1672 1673 gfc_free_expr (open->unit); 1674 gfc_free_expr (open->iomsg); 1675 gfc_free_expr (open->iostat); 1676 gfc_free_expr (open->file); 1677 gfc_free_expr (open->status); 1678 gfc_free_expr (open->access); 1679 gfc_free_expr (open->form); 1680 gfc_free_expr (open->recl); 1681 gfc_free_expr (open->blank); 1682 gfc_free_expr (open->position); 1683 gfc_free_expr (open->action); 1684 gfc_free_expr (open->delim); 1685 gfc_free_expr (open->pad); 1686 gfc_free_expr (open->decimal); 1687 gfc_free_expr (open->encoding); 1688 gfc_free_expr (open->round); 1689 gfc_free_expr (open->sign); 1690 gfc_free_expr (open->convert); 1691 gfc_free_expr (open->asynchronous); 1692 gfc_free_expr (open->newunit); 1693 free (open); 1694} 1695 1696 1697/* Resolve everything in a gfc_open structure. */ 1698 1699bool 1700gfc_resolve_open (gfc_open *open) 1701{ 1702 1703 RESOLVE_TAG (&tag_unit, open->unit); 1704 RESOLVE_TAG (&tag_iomsg, open->iomsg); 1705 RESOLVE_TAG (&tag_iostat, open->iostat); 1706 RESOLVE_TAG (&tag_file, open->file); 1707 RESOLVE_TAG (&tag_status, open->status); 1708 RESOLVE_TAG (&tag_e_access, open->access); 1709 RESOLVE_TAG (&tag_e_form, open->form); 1710 RESOLVE_TAG (&tag_e_recl, open->recl); 1711 RESOLVE_TAG (&tag_e_blank, open->blank); 1712 RESOLVE_TAG (&tag_e_position, open->position); 1713 RESOLVE_TAG (&tag_e_action, open->action); 1714 RESOLVE_TAG (&tag_e_delim, open->delim); 1715 RESOLVE_TAG (&tag_e_pad, open->pad); 1716 RESOLVE_TAG (&tag_e_decimal, open->decimal); 1717 RESOLVE_TAG (&tag_e_encoding, open->encoding); 1718 RESOLVE_TAG (&tag_e_async, open->asynchronous); 1719 RESOLVE_TAG (&tag_e_round, open->round); 1720 RESOLVE_TAG (&tag_e_sign, open->sign); 1721 RESOLVE_TAG (&tag_convert, open->convert); 1722 RESOLVE_TAG (&tag_newunit, open->newunit); 1723 1724 if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) 1725 return false; 1726 1727 return true; 1728} 1729 1730 1731/* Check if a given value for a SPECIFIER is either in the list of values 1732 allowed in F95 or F2003, issuing an error message and returning a zero 1733 value if it is not allowed. */ 1734 1735static int 1736compare_to_allowed_values (const char *specifier, const char *allowed[], 1737 const char *allowed_f2003[], 1738 const char *allowed_gnu[], gfc_char_t *value, 1739 const char *statement, bool warn) 1740{ 1741 int i; 1742 unsigned int len; 1743 1744 len = gfc_wide_strlen (value); 1745 if (len > 0) 1746 { 1747 for (len--; len > 0; len--) 1748 if (value[len] != ' ') 1749 break; 1750 len++; 1751 } 1752 1753 for (i = 0; allowed[i]; i++) 1754 if (len == strlen (allowed[i]) 1755 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) 1756 return 1; 1757 1758 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) 1759 if (len == strlen (allowed_f2003[i]) 1760 && gfc_wide_strncasecmp (value, allowed_f2003[i], 1761 strlen (allowed_f2003[i])) == 0) 1762 { 1763 notification n = gfc_notification_std (GFC_STD_F2003); 1764 1765 if (n == WARNING || (warn && n == ERROR)) 1766 { 1767 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C " 1768 "has value %qs", specifier, statement, 1769 allowed_f2003[i]); 1770 return 1; 1771 } 1772 else 1773 if (n == ERROR) 1774 { 1775 gfc_notify_std (GFC_STD_F2003, "%s specifier in " 1776 "%s statement at %C has value %qs", specifier, 1777 statement, allowed_f2003[i]); 1778 return 0; 1779 } 1780 1781 /* n == SILENT */ 1782 return 1; 1783 } 1784 1785 for (i = 0; allowed_gnu && allowed_gnu[i]; i++) 1786 if (len == strlen (allowed_gnu[i]) 1787 && gfc_wide_strncasecmp (value, allowed_gnu[i], 1788 strlen (allowed_gnu[i])) == 0) 1789 { 1790 notification n = gfc_notification_std (GFC_STD_GNU); 1791 1792 if (n == WARNING || (warn && n == ERROR)) 1793 { 1794 gfc_warning (0, "Extension: %s specifier in %s statement at %C " 1795 "has value %qs", specifier, statement, 1796 allowed_gnu[i]); 1797 return 1; 1798 } 1799 else 1800 if (n == ERROR) 1801 { 1802 gfc_notify_std (GFC_STD_GNU, "%s specifier in " 1803 "%s statement at %C has value %qs", specifier, 1804 statement, allowed_gnu[i]); 1805 return 0; 1806 } 1807 1808 /* n == SILENT */ 1809 return 1; 1810 } 1811 1812 if (warn) 1813 { 1814 char *s = gfc_widechar_to_char (value, -1); 1815 gfc_warning (0, 1816 "%s specifier in %s statement at %C has invalid value %qs", 1817 specifier, statement, s); 1818 free (s); 1819 return 1; 1820 } 1821 else 1822 { 1823 char *s = gfc_widechar_to_char (value, -1); 1824 gfc_error ("%s specifier in %s statement at %C has invalid value %qs", 1825 specifier, statement, s); 1826 free (s); 1827 return 0; 1828 } 1829} 1830 1831 1832/* Match an OPEN statement. */ 1833 1834match 1835gfc_match_open (void) 1836{ 1837 gfc_open *open; 1838 match m; 1839 bool warn; 1840 1841 m = gfc_match_char ('('); 1842 if (m == MATCH_NO) 1843 return m; 1844 1845 open = XCNEW (gfc_open); 1846 1847 m = match_open_element (open); 1848 1849 if (m == MATCH_ERROR) 1850 goto cleanup; 1851 if (m == MATCH_NO) 1852 { 1853 m = gfc_match_expr (&open->unit); 1854 if (m == MATCH_ERROR) 1855 goto cleanup; 1856 } 1857 1858 for (;;) 1859 { 1860 if (gfc_match_char (')') == MATCH_YES) 1861 break; 1862 if (gfc_match_char (',') != MATCH_YES) 1863 goto syntax; 1864 1865 m = match_open_element (open); 1866 if (m == MATCH_ERROR) 1867 goto cleanup; 1868 if (m == MATCH_NO) 1869 goto syntax; 1870 } 1871 1872 if (gfc_match_eos () == MATCH_NO) 1873 goto syntax; 1874 1875 if (gfc_pure (NULL)) 1876 { 1877 gfc_error ("OPEN statement not allowed in PURE procedure at %C"); 1878 goto cleanup; 1879 } 1880 1881 gfc_unset_implicit_pure (NULL); 1882 1883 warn = (open->err || open->iostat) ? true : false; 1884 1885 /* Checks on NEWUNIT specifier. */ 1886 if (open->newunit) 1887 { 1888 if (open->unit) 1889 { 1890 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C"); 1891 goto cleanup; 1892 } 1893 1894 if (!(open->file || (open->status 1895 && gfc_wide_strncasecmp (open->status->value.character.string, 1896 "scratch", 7) == 0))) 1897 { 1898 gfc_error ("NEWUNIT specifier must have FILE= " 1899 "or STATUS='scratch' at %C"); 1900 goto cleanup; 1901 } 1902 } 1903 else if (!open->unit) 1904 { 1905 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified"); 1906 goto cleanup; 1907 } 1908 1909 /* Checks on the ACCESS specifier. */ 1910 if (open->access && open->access->expr_type == EXPR_CONSTANT) 1911 { 1912 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL }; 1913 static const char *access_f2003[] = { "STREAM", NULL }; 1914 static const char *access_gnu[] = { "APPEND", NULL }; 1915 1916 if (!is_char_type ("ACCESS", open->access)) 1917 goto cleanup; 1918 1919 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, 1920 access_gnu, 1921 open->access->value.character.string, 1922 "OPEN", warn)) 1923 goto cleanup; 1924 } 1925 1926 /* Checks on the ACTION specifier. */ 1927 if (open->action && open->action->expr_type == EXPR_CONSTANT) 1928 { 1929 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; 1930 1931 if (!is_char_type ("ACTION", open->action)) 1932 goto cleanup; 1933 1934 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, 1935 open->action->value.character.string, 1936 "OPEN", warn)) 1937 goto cleanup; 1938 } 1939 1940 /* Checks on the ASYNCHRONOUS specifier. */ 1941 if (open->asynchronous) 1942 { 1943 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C " 1944 "not allowed in Fortran 95")) 1945 goto cleanup; 1946 1947 if (!is_char_type ("ASYNCHRONOUS", open->asynchronous)) 1948 goto cleanup; 1949 1950 if (open->asynchronous->expr_type == EXPR_CONSTANT) 1951 { 1952 static const char * asynchronous[] = { "YES", "NO", NULL }; 1953 1954 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, 1955 NULL, NULL, open->asynchronous->value.character.string, 1956 "OPEN", warn)) 1957 goto cleanup; 1958 } 1959 } 1960 1961 /* Checks on the BLANK specifier. */ 1962 if (open->blank) 1963 { 1964 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " 1965 "not allowed in Fortran 95")) 1966 goto cleanup; 1967 1968 if (!is_char_type ("BLANK", open->blank)) 1969 goto cleanup; 1970 1971 if (open->blank->expr_type == EXPR_CONSTANT) 1972 { 1973 static const char *blank[] = { "ZERO", "NULL", NULL }; 1974 1975 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, 1976 open->blank->value.character.string, 1977 "OPEN", warn)) 1978 goto cleanup; 1979 } 1980 } 1981 1982 /* Checks on the DECIMAL specifier. */ 1983 if (open->decimal) 1984 { 1985 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " 1986 "not allowed in Fortran 95")) 1987 goto cleanup; 1988 1989 if (!is_char_type ("DECIMAL", open->decimal)) 1990 goto cleanup; 1991 1992 if (open->decimal->expr_type == EXPR_CONSTANT) 1993 { 1994 static const char * decimal[] = { "COMMA", "POINT", NULL }; 1995 1996 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, 1997 open->decimal->value.character.string, 1998 "OPEN", warn)) 1999 goto cleanup; 2000 } 2001 } 2002 2003 /* Checks on the DELIM specifier. */ 2004 if (open->delim) 2005 { 2006 if (open->delim->expr_type == EXPR_CONSTANT) 2007 { 2008 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; 2009 2010 if (!is_char_type ("DELIM", open->delim)) 2011 goto cleanup; 2012 2013 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, 2014 open->delim->value.character.string, 2015 "OPEN", warn)) 2016 goto cleanup; 2017 } 2018 } 2019 2020 /* Checks on the ENCODING specifier. */ 2021 if (open->encoding) 2022 { 2023 if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C " 2024 "not allowed in Fortran 95")) 2025 goto cleanup; 2026 2027 if (!is_char_type ("ENCODING", open->encoding)) 2028 goto cleanup; 2029 2030 if (open->encoding->expr_type == EXPR_CONSTANT) 2031 { 2032 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; 2033 2034 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, 2035 open->encoding->value.character.string, 2036 "OPEN", warn)) 2037 goto cleanup; 2038 } 2039 } 2040 2041 /* Checks on the FORM specifier. */ 2042 if (open->form && open->form->expr_type == EXPR_CONSTANT) 2043 { 2044 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; 2045 2046 if (!is_char_type ("FORM", open->form)) 2047 goto cleanup; 2048 2049 if (!compare_to_allowed_values ("FORM", form, NULL, NULL, 2050 open->form->value.character.string, 2051 "OPEN", warn)) 2052 goto cleanup; 2053 } 2054 2055 /* Checks on the PAD specifier. */ 2056 if (open->pad && open->pad->expr_type == EXPR_CONSTANT) 2057 { 2058 static const char *pad[] = { "YES", "NO", NULL }; 2059 2060 if (!is_char_type ("PAD", open->pad)) 2061 goto cleanup; 2062 2063 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, 2064 open->pad->value.character.string, 2065 "OPEN", warn)) 2066 goto cleanup; 2067 } 2068 2069 /* Checks on the POSITION specifier. */ 2070 if (open->position && open->position->expr_type == EXPR_CONSTANT) 2071 { 2072 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; 2073 2074 if (!is_char_type ("POSITION", open->position)) 2075 goto cleanup; 2076 2077 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, 2078 open->position->value.character.string, 2079 "OPEN", warn)) 2080 goto cleanup; 2081 } 2082 2083 /* Checks on the ROUND specifier. */ 2084 if (open->round) 2085 { 2086 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " 2087 "not allowed in Fortran 95")) 2088 goto cleanup; 2089 2090 if (!is_char_type ("ROUND", open->round)) 2091 goto cleanup; 2092 2093 if (open->round->expr_type == EXPR_CONSTANT) 2094 { 2095 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", 2096 "COMPATIBLE", "PROCESSOR_DEFINED", 2097 NULL }; 2098 2099 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, 2100 open->round->value.character.string, 2101 "OPEN", warn)) 2102 goto cleanup; 2103 } 2104 } 2105 2106 /* Checks on the SIGN specifier. */ 2107 if (open->sign) 2108 { 2109 if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " 2110 "not allowed in Fortran 95")) 2111 goto cleanup; 2112 2113 if (!is_char_type ("SIGN", open->sign)) 2114 goto cleanup; 2115 2116 if (open->sign->expr_type == EXPR_CONSTANT) 2117 { 2118 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", 2119 NULL }; 2120 2121 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, 2122 open->sign->value.character.string, 2123 "OPEN", warn)) 2124 goto cleanup; 2125 } 2126 } 2127 2128#define warn_or_error(...) \ 2129{ \ 2130 if (warn) \ 2131 gfc_warning (0, __VA_ARGS__); \ 2132 else \ 2133 { \ 2134 gfc_error (__VA_ARGS__); \ 2135 goto cleanup; \ 2136 } \ 2137} 2138 2139 /* Checks on the RECL specifier. */ 2140 if (open->recl && open->recl->expr_type == EXPR_CONSTANT 2141 && open->recl->ts.type == BT_INTEGER 2142 && mpz_sgn (open->recl->value.integer) != 1) 2143 { 2144 warn_or_error ("RECL in OPEN statement at %C must be positive"); 2145 } 2146 2147 /* Checks on the STATUS specifier. */ 2148 if (open->status && open->status->expr_type == EXPR_CONSTANT) 2149 { 2150 static const char *status[] = { "OLD", "NEW", "SCRATCH", 2151 "REPLACE", "UNKNOWN", NULL }; 2152 2153 if (!is_char_type ("STATUS", open->status)) 2154 goto cleanup; 2155 2156 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, 2157 open->status->value.character.string, 2158 "OPEN", warn)) 2159 goto cleanup; 2160 2161 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, 2162 the FILE= specifier shall appear. */ 2163 if (open->file == NULL 2164 && (gfc_wide_strncasecmp (open->status->value.character.string, 2165 "replace", 7) == 0 2166 || gfc_wide_strncasecmp (open->status->value.character.string, 2167 "new", 3) == 0)) 2168 { 2169 char *s = gfc_widechar_to_char (open->status->value.character.string, 2170 -1); 2171 warn_or_error ("The STATUS specified in OPEN statement at %C is " 2172 "%qs and no FILE specifier is present", s); 2173 free (s); 2174 } 2175 2176 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, 2177 the FILE= specifier shall not appear. */ 2178 if (gfc_wide_strncasecmp (open->status->value.character.string, 2179 "scratch", 7) == 0 && open->file) 2180 { 2181 warn_or_error ("The STATUS specified in OPEN statement at %C " 2182 "cannot have the value SCRATCH if a FILE specifier " 2183 "is present"); 2184 } 2185 } 2186 2187 /* Things that are not allowed for unformatted I/O. */ 2188 if (open->form && open->form->expr_type == EXPR_CONSTANT 2189 && (open->delim || open->decimal || open->encoding || open->round 2190 || open->sign || open->pad || open->blank) 2191 && gfc_wide_strncasecmp (open->form->value.character.string, 2192 "unformatted", 11) == 0) 2193 { 2194 const char *spec = (open->delim ? "DELIM " 2195 : (open->pad ? "PAD " : open->blank 2196 ? "BLANK " : "")); 2197 2198 warn_or_error ("%s specifier at %C not allowed in OPEN statement for " 2199 "unformatted I/O", spec); 2200 } 2201 2202 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT 2203 && gfc_wide_strncasecmp (open->access->value.character.string, 2204 "stream", 6) == 0) 2205 { 2206 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for " 2207 "stream I/O"); 2208 } 2209 2210 if (open->position 2211 && open->access && open->access->expr_type == EXPR_CONSTANT 2212 && !(gfc_wide_strncasecmp (open->access->value.character.string, 2213 "sequential", 10) == 0 2214 || gfc_wide_strncasecmp (open->access->value.character.string, 2215 "stream", 6) == 0 2216 || gfc_wide_strncasecmp (open->access->value.character.string, 2217 "append", 6) == 0)) 2218 { 2219 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed " 2220 "for stream or sequential ACCESS"); 2221 } 2222 2223#undef warn_or_error 2224 2225 new_st.op = EXEC_OPEN; 2226 new_st.ext.open = open; 2227 return MATCH_YES; 2228 2229syntax: 2230 gfc_syntax_error (ST_OPEN); 2231 2232cleanup: 2233 gfc_free_open (open); 2234 return MATCH_ERROR; 2235} 2236 2237 2238/* Free a gfc_close structure an all its expressions. */ 2239 2240void 2241gfc_free_close (gfc_close *close) 2242{ 2243 if (close == NULL) 2244 return; 2245 2246 gfc_free_expr (close->unit); 2247 gfc_free_expr (close->iomsg); 2248 gfc_free_expr (close->iostat); 2249 gfc_free_expr (close->status); 2250 free (close); 2251} 2252 2253 2254/* Match elements of a CLOSE statement. */ 2255 2256static match 2257match_close_element (gfc_close *close) 2258{ 2259 match m; 2260 2261 m = match_etag (&tag_unit, &close->unit); 2262 if (m != MATCH_NO) 2263 return m; 2264 m = match_etag (&tag_status, &close->status); 2265 if (m != MATCH_NO) 2266 return m; 2267 m = match_etag (&tag_iomsg, &close->iomsg); 2268 if (m == MATCH_YES && !check_char_variable (close->iomsg)) 2269 return MATCH_ERROR; 2270 if (m != MATCH_NO) 2271 return m; 2272 m = match_out_tag (&tag_iostat, &close->iostat); 2273 if (m != MATCH_NO) 2274 return m; 2275 m = match_ltag (&tag_err, &close->err); 2276 if (m != MATCH_NO) 2277 return m; 2278 2279 return MATCH_NO; 2280} 2281 2282 2283/* Match a CLOSE statement. */ 2284 2285match 2286gfc_match_close (void) 2287{ 2288 gfc_close *close; 2289 match m; 2290 bool warn; 2291 2292 m = gfc_match_char ('('); 2293 if (m == MATCH_NO) 2294 return m; 2295 2296 close = XCNEW (gfc_close); 2297 2298 m = match_close_element (close); 2299 2300 if (m == MATCH_ERROR) 2301 goto cleanup; 2302 if (m == MATCH_NO) 2303 { 2304 m = gfc_match_expr (&close->unit); 2305 if (m == MATCH_NO) 2306 goto syntax; 2307 if (m == MATCH_ERROR) 2308 goto cleanup; 2309 } 2310 2311 for (;;) 2312 { 2313 if (gfc_match_char (')') == MATCH_YES) 2314 break; 2315 if (gfc_match_char (',') != MATCH_YES) 2316 goto syntax; 2317 2318 m = match_close_element (close); 2319 if (m == MATCH_ERROR) 2320 goto cleanup; 2321 if (m == MATCH_NO) 2322 goto syntax; 2323 } 2324 2325 if (gfc_match_eos () == MATCH_NO) 2326 goto syntax; 2327 2328 if (gfc_pure (NULL)) 2329 { 2330 gfc_error ("CLOSE statement not allowed in PURE procedure at %C"); 2331 goto cleanup; 2332 } 2333 2334 gfc_unset_implicit_pure (NULL); 2335 2336 warn = (close->iostat || close->err) ? true : false; 2337 2338 /* Checks on the STATUS specifier. */ 2339 if (close->status && close->status->expr_type == EXPR_CONSTANT) 2340 { 2341 static const char *status[] = { "KEEP", "DELETE", NULL }; 2342 2343 if (!is_char_type ("STATUS", close->status)) 2344 goto cleanup; 2345 2346 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, 2347 close->status->value.character.string, 2348 "CLOSE", warn)) 2349 goto cleanup; 2350 } 2351 2352 new_st.op = EXEC_CLOSE; 2353 new_st.ext.close = close; 2354 return MATCH_YES; 2355 2356syntax: 2357 gfc_syntax_error (ST_CLOSE); 2358 2359cleanup: 2360 gfc_free_close (close); 2361 return MATCH_ERROR; 2362} 2363 2364 2365/* Resolve everything in a gfc_close structure. */ 2366 2367bool 2368gfc_resolve_close (gfc_close *close) 2369{ 2370 RESOLVE_TAG (&tag_unit, close->unit); 2371 RESOLVE_TAG (&tag_iomsg, close->iomsg); 2372 RESOLVE_TAG (&tag_iostat, close->iostat); 2373 RESOLVE_TAG (&tag_status, close->status); 2374 2375 if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) 2376 return false; 2377 2378 if (close->unit == NULL) 2379 { 2380 /* Find a locus from one of the arguments to close, when UNIT is 2381 not specified. */ 2382 locus loc = gfc_current_locus; 2383 if (close->status) 2384 loc = close->status->where; 2385 else if (close->iostat) 2386 loc = close->iostat->where; 2387 else if (close->iomsg) 2388 loc = close->iomsg->where; 2389 else if (close->err) 2390 loc = close->err->where; 2391 2392 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc); 2393 return false; 2394 } 2395 2396 if (close->unit->expr_type == EXPR_CONSTANT 2397 && close->unit->ts.type == BT_INTEGER 2398 && mpz_sgn (close->unit->value.integer) < 0) 2399 { 2400 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", 2401 &close->unit->where); 2402 } 2403 2404 return true; 2405} 2406 2407 2408/* Free a gfc_filepos structure. */ 2409 2410void 2411gfc_free_filepos (gfc_filepos *fp) 2412{ 2413 gfc_free_expr (fp->unit); 2414 gfc_free_expr (fp->iomsg); 2415 gfc_free_expr (fp->iostat); 2416 free (fp); 2417} 2418 2419 2420/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */ 2421 2422static match 2423match_file_element (gfc_filepos *fp) 2424{ 2425 match m; 2426 2427 m = match_etag (&tag_unit, &fp->unit); 2428 if (m != MATCH_NO) 2429 return m; 2430 m = match_etag (&tag_iomsg, &fp->iomsg); 2431 if (m == MATCH_YES && !check_char_variable (fp->iomsg)) 2432 return MATCH_ERROR; 2433 if (m != MATCH_NO) 2434 return m; 2435 m = match_out_tag (&tag_iostat, &fp->iostat); 2436 if (m != MATCH_NO) 2437 return m; 2438 m = match_ltag (&tag_err, &fp->err); 2439 if (m != MATCH_NO) 2440 return m; 2441 2442 return MATCH_NO; 2443} 2444 2445 2446/* Match the second half of the file-positioning statements, REWIND, 2447 BACKSPACE, ENDFILE, or the FLUSH statement. */ 2448 2449static match 2450match_filepos (gfc_statement st, gfc_exec_op op) 2451{ 2452 gfc_filepos *fp; 2453 match m; 2454 2455 fp = XCNEW (gfc_filepos); 2456 2457 if (gfc_match_char ('(') == MATCH_NO) 2458 { 2459 m = gfc_match_expr (&fp->unit); 2460 if (m == MATCH_ERROR) 2461 goto cleanup; 2462 if (m == MATCH_NO) 2463 goto syntax; 2464 2465 goto done; 2466 } 2467 2468 m = match_file_element (fp); 2469 if (m == MATCH_ERROR) 2470 goto done; 2471 if (m == MATCH_NO) 2472 { 2473 m = gfc_match_expr (&fp->unit); 2474 if (m == MATCH_ERROR || m == MATCH_NO) 2475 goto syntax; 2476 } 2477 2478 for (;;) 2479 { 2480 if (gfc_match_char (')') == MATCH_YES) 2481 break; 2482 if (gfc_match_char (',') != MATCH_YES) 2483 goto syntax; 2484 2485 m = match_file_element (fp); 2486 if (m == MATCH_ERROR) 2487 goto cleanup; 2488 if (m == MATCH_NO) 2489 goto syntax; 2490 } 2491 2492done: 2493 if (gfc_match_eos () != MATCH_YES) 2494 goto syntax; 2495 2496 if (gfc_pure (NULL)) 2497 { 2498 gfc_error ("%s statement not allowed in PURE procedure at %C", 2499 gfc_ascii_statement (st)); 2500 2501 goto cleanup; 2502 } 2503 2504 gfc_unset_implicit_pure (NULL); 2505 2506 new_st.op = op; 2507 new_st.ext.filepos = fp; 2508 return MATCH_YES; 2509 2510syntax: 2511 gfc_syntax_error (st); 2512 2513cleanup: 2514 gfc_free_filepos (fp); 2515 return MATCH_ERROR; 2516} 2517 2518 2519bool 2520gfc_resolve_filepos (gfc_filepos *fp) 2521{ 2522 RESOLVE_TAG (&tag_unit, fp->unit); 2523 RESOLVE_TAG (&tag_iostat, fp->iostat); 2524 RESOLVE_TAG (&tag_iomsg, fp->iomsg); 2525 if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) 2526 return false; 2527 2528 if (!fp->unit && (fp->iostat || fp->iomsg)) 2529 { 2530 locus where; 2531 where = fp->iostat ? fp->iostat->where : fp->iomsg->where; 2532 gfc_error ("UNIT number missing in statement at %L", &where); 2533 return false; 2534 } 2535 2536 if (fp->unit->expr_type == EXPR_CONSTANT 2537 && fp->unit->ts.type == BT_INTEGER 2538 && mpz_sgn (fp->unit->value.integer) < 0) 2539 { 2540 gfc_error ("UNIT number in statement at %L must be non-negative", 2541 &fp->unit->where); 2542 return false; 2543 } 2544 2545 return true; 2546} 2547 2548 2549/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND, 2550 and the FLUSH statement. */ 2551 2552match 2553gfc_match_endfile (void) 2554{ 2555 return match_filepos (ST_END_FILE, EXEC_ENDFILE); 2556} 2557 2558match 2559gfc_match_backspace (void) 2560{ 2561 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE); 2562} 2563 2564match 2565gfc_match_rewind (void) 2566{ 2567 return match_filepos (ST_REWIND, EXEC_REWIND); 2568} 2569 2570match 2571gfc_match_flush (void) 2572{ 2573 if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C")) 2574 return MATCH_ERROR; 2575 2576 return match_filepos (ST_FLUSH, EXEC_FLUSH); 2577} 2578 2579/******************** Data Transfer Statements *********************/ 2580 2581/* Return a default unit number. */ 2582 2583static gfc_expr * 2584default_unit (io_kind k) 2585{ 2586 int unit; 2587 2588 if (k == M_READ) 2589 unit = 5; 2590 else 2591 unit = 6; 2592 2593 return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit); 2594} 2595 2596 2597/* Match a unit specification for a data transfer statement. */ 2598 2599static match 2600match_dt_unit (io_kind k, gfc_dt *dt) 2601{ 2602 gfc_expr *e; 2603 2604 if (gfc_match_char ('*') == MATCH_YES) 2605 { 2606 if (dt->io_unit != NULL) 2607 goto conflict; 2608 2609 dt->io_unit = default_unit (k); 2610 return MATCH_YES; 2611 } 2612 2613 if (gfc_match_expr (&e) == MATCH_YES) 2614 { 2615 if (dt->io_unit != NULL) 2616 { 2617 gfc_free_expr (e); 2618 goto conflict; 2619 } 2620 2621 dt->io_unit = e; 2622 return MATCH_YES; 2623 } 2624 2625 return MATCH_NO; 2626 2627conflict: 2628 gfc_error ("Duplicate UNIT specification at %C"); 2629 return MATCH_ERROR; 2630} 2631 2632 2633/* Match a format specification. */ 2634 2635static match 2636match_dt_format (gfc_dt *dt) 2637{ 2638 locus where; 2639 gfc_expr *e; 2640 gfc_st_label *label; 2641 match m; 2642 2643 where = gfc_current_locus; 2644 2645 if (gfc_match_char ('*') == MATCH_YES) 2646 { 2647 if (dt->format_expr != NULL || dt->format_label != NULL) 2648 goto conflict; 2649 2650 dt->format_label = &format_asterisk; 2651 return MATCH_YES; 2652 } 2653 2654 if ((m = gfc_match_st_label (&label)) == MATCH_YES) 2655 { 2656 char c; 2657 2658 /* Need to check if the format label is actually either an operand 2659 to a user-defined operator or is a kind type parameter. That is, 2660 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER. 2661 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */ 2662 2663 gfc_gobble_whitespace (); 2664 c = gfc_peek_ascii_char (); 2665 if (c == '.' || c == '_') 2666 gfc_current_locus = where; 2667 else 2668 { 2669 if (dt->format_expr != NULL || dt->format_label != NULL) 2670 { 2671 gfc_free_st_label (label); 2672 goto conflict; 2673 } 2674 2675 if (!gfc_reference_st_label (label, ST_LABEL_FORMAT)) 2676 return MATCH_ERROR; 2677 2678 dt->format_label = label; 2679 return MATCH_YES; 2680 } 2681 } 2682 else if (m == MATCH_ERROR) 2683 /* The label was zero or too large. Emit the correct diagnosis. */ 2684 return MATCH_ERROR; 2685 2686 if (gfc_match_expr (&e) == MATCH_YES) 2687 { 2688 if (dt->format_expr != NULL || dt->format_label != NULL) 2689 { 2690 gfc_free_expr (e); 2691 goto conflict; 2692 } 2693 dt->format_expr = e; 2694 return MATCH_YES; 2695 } 2696 2697 gfc_current_locus = where; /* The only case where we have to restore */ 2698 2699 return MATCH_NO; 2700 2701conflict: 2702 gfc_error ("Duplicate format specification at %C"); 2703 return MATCH_ERROR; 2704} 2705 2706 2707/* Traverse a namelist that is part of a READ statement to make sure 2708 that none of the variables in the namelist are INTENT(IN). Returns 2709 nonzero if we find such a variable. */ 2710 2711static int 2712check_namelist (gfc_symbol *sym) 2713{ 2714 gfc_namelist *p; 2715 2716 for (p = sym->namelist; p; p = p->next) 2717 if (p->sym->attr.intent == INTENT_IN) 2718 { 2719 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C", 2720 p->sym->name, sym->name); 2721 return 1; 2722 } 2723 2724 return 0; 2725} 2726 2727 2728/* Match a single data transfer element. */ 2729 2730static match 2731match_dt_element (io_kind k, gfc_dt *dt) 2732{ 2733 char name[GFC_MAX_SYMBOL_LEN + 1]; 2734 gfc_symbol *sym; 2735 match m; 2736 2737 if (gfc_match (" unit =") == MATCH_YES) 2738 { 2739 m = match_dt_unit (k, dt); 2740 if (m != MATCH_NO) 2741 return m; 2742 } 2743 2744 if (gfc_match (" fmt =") == MATCH_YES) 2745 { 2746 m = match_dt_format (dt); 2747 if (m != MATCH_NO) 2748 return m; 2749 } 2750 2751 if (gfc_match (" nml = %n", name) == MATCH_YES) 2752 { 2753 if (dt->namelist != NULL) 2754 { 2755 gfc_error ("Duplicate NML specification at %C"); 2756 return MATCH_ERROR; 2757 } 2758 2759 if (gfc_find_symbol (name, NULL, 1, &sym)) 2760 return MATCH_ERROR; 2761 2762 if (sym == NULL || sym->attr.flavor != FL_NAMELIST) 2763 { 2764 gfc_error ("Symbol %qs at %C must be a NAMELIST group name", 2765 sym != NULL ? sym->name : name); 2766 return MATCH_ERROR; 2767 } 2768 2769 dt->namelist = sym; 2770 if (k == M_READ && check_namelist (sym)) 2771 return MATCH_ERROR; 2772 2773 return MATCH_YES; 2774 } 2775 2776 m = match_etag (&tag_e_async, &dt->asynchronous); 2777 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", dt->asynchronous)) 2778 return MATCH_ERROR; 2779 if (m != MATCH_NO) 2780 return m; 2781 m = match_etag (&tag_e_blank, &dt->blank); 2782 if (m != MATCH_NO) 2783 return m; 2784 m = match_etag (&tag_e_delim, &dt->delim); 2785 if (m != MATCH_NO) 2786 return m; 2787 m = match_etag (&tag_e_pad, &dt->pad); 2788 if (m != MATCH_NO) 2789 return m; 2790 m = match_etag (&tag_e_sign, &dt->sign); 2791 if (m != MATCH_NO) 2792 return m; 2793 m = match_etag (&tag_e_round, &dt->round); 2794 if (m != MATCH_NO) 2795 return m; 2796 m = match_out_tag (&tag_id, &dt->id); 2797 if (m != MATCH_NO) 2798 return m; 2799 m = match_etag (&tag_e_decimal, &dt->decimal); 2800 if (m != MATCH_NO) 2801 return m; 2802 m = match_etag (&tag_rec, &dt->rec); 2803 if (m != MATCH_NO) 2804 return m; 2805 m = match_etag (&tag_spos, &dt->pos); 2806 if (m != MATCH_NO) 2807 return m; 2808 m = match_etag (&tag_iomsg, &dt->iomsg); 2809 if (m == MATCH_YES && !check_char_variable (dt->iomsg)) 2810 return MATCH_ERROR; 2811 if (m != MATCH_NO) 2812 return m; 2813 2814 m = match_out_tag (&tag_iostat, &dt->iostat); 2815 if (m != MATCH_NO) 2816 return m; 2817 m = match_ltag (&tag_err, &dt->err); 2818 if (m == MATCH_YES) 2819 dt->err_where = gfc_current_locus; 2820 if (m != MATCH_NO) 2821 return m; 2822 m = match_etag (&tag_advance, &dt->advance); 2823 if (m != MATCH_NO) 2824 return m; 2825 m = match_out_tag (&tag_size, &dt->size); 2826 if (m != MATCH_NO) 2827 return m; 2828 2829 m = match_ltag (&tag_end, &dt->end); 2830 if (m == MATCH_YES) 2831 { 2832 if (k == M_WRITE) 2833 { 2834 gfc_error ("END tag at %C not allowed in output statement"); 2835 return MATCH_ERROR; 2836 } 2837 dt->end_where = gfc_current_locus; 2838 } 2839 if (m != MATCH_NO) 2840 return m; 2841 2842 m = match_ltag (&tag_eor, &dt->eor); 2843 if (m == MATCH_YES) 2844 dt->eor_where = gfc_current_locus; 2845 if (m != MATCH_NO) 2846 return m; 2847 2848 return MATCH_NO; 2849} 2850 2851 2852/* Free a data transfer structure and everything below it. */ 2853 2854void 2855gfc_free_dt (gfc_dt *dt) 2856{ 2857 if (dt == NULL) 2858 return; 2859 2860 gfc_free_expr (dt->io_unit); 2861 gfc_free_expr (dt->format_expr); 2862 gfc_free_expr (dt->rec); 2863 gfc_free_expr (dt->advance); 2864 gfc_free_expr (dt->iomsg); 2865 gfc_free_expr (dt->iostat); 2866 gfc_free_expr (dt->size); 2867 gfc_free_expr (dt->pad); 2868 gfc_free_expr (dt->delim); 2869 gfc_free_expr (dt->sign); 2870 gfc_free_expr (dt->round); 2871 gfc_free_expr (dt->blank); 2872 gfc_free_expr (dt->decimal); 2873 gfc_free_expr (dt->pos); 2874 gfc_free_expr (dt->dt_io_kind); 2875 /* dt->extra_comma is a link to dt_io_kind if it is set. */ 2876 free (dt); 2877} 2878 2879 2880/* Resolve everything in a gfc_dt structure. */ 2881 2882bool 2883gfc_resolve_dt (gfc_dt *dt, locus *loc) 2884{ 2885 gfc_expr *e; 2886 io_kind k; 2887 2888 /* This is set in any case. */ 2889 gcc_assert (dt->dt_io_kind); 2890 k = dt->dt_io_kind->value.iokind; 2891 2892 RESOLVE_TAG (&tag_format, dt->format_expr); 2893 RESOLVE_TAG (&tag_rec, dt->rec); 2894 RESOLVE_TAG (&tag_spos, dt->pos); 2895 RESOLVE_TAG (&tag_advance, dt->advance); 2896 RESOLVE_TAG (&tag_id, dt->id); 2897 RESOLVE_TAG (&tag_iomsg, dt->iomsg); 2898 RESOLVE_TAG (&tag_iostat, dt->iostat); 2899 RESOLVE_TAG (&tag_size, dt->size); 2900 RESOLVE_TAG (&tag_e_pad, dt->pad); 2901 RESOLVE_TAG (&tag_e_delim, dt->delim); 2902 RESOLVE_TAG (&tag_e_sign, dt->sign); 2903 RESOLVE_TAG (&tag_e_round, dt->round); 2904 RESOLVE_TAG (&tag_e_blank, dt->blank); 2905 RESOLVE_TAG (&tag_e_decimal, dt->decimal); 2906 RESOLVE_TAG (&tag_e_async, dt->asynchronous); 2907 2908 e = dt->io_unit; 2909 if (e == NULL) 2910 { 2911 gfc_error ("UNIT not specified at %L", loc); 2912 return false; 2913 } 2914 2915 if (gfc_resolve_expr (e) 2916 && (e->ts.type != BT_INTEGER 2917 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE))) 2918 { 2919 /* If there is no extra comma signifying the "format" form of the IO 2920 statement, then this must be an error. */ 2921 if (!dt->extra_comma) 2922 { 2923 gfc_error ("UNIT specification at %L must be an INTEGER expression " 2924 "or a CHARACTER variable", &e->where); 2925 return false; 2926 } 2927 else 2928 { 2929 /* At this point, we have an extra comma. If io_unit has arrived as 2930 type character, we assume its really the "format" form of the I/O 2931 statement. We set the io_unit to the default unit and format to 2932 the character expression. See F95 Standard section 9.4. */ 2933 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) 2934 { 2935 dt->format_expr = dt->io_unit; 2936 dt->io_unit = default_unit (k); 2937 2938 /* Nullify this pointer now so that a warning/error is not 2939 triggered below for the "Extension". */ 2940 dt->extra_comma = NULL; 2941 } 2942 2943 if (k == M_WRITE) 2944 { 2945 gfc_error ("Invalid form of WRITE statement at %L, UNIT required", 2946 &dt->extra_comma->where); 2947 return false; 2948 } 2949 } 2950 } 2951 2952 if (e->ts.type == BT_CHARACTER) 2953 { 2954 if (gfc_has_vector_index (e)) 2955 { 2956 gfc_error ("Internal unit with vector subscript at %L", &e->where); 2957 return false; 2958 } 2959 2960 /* If we are writing, make sure the internal unit can be changed. */ 2961 gcc_assert (k != M_PRINT); 2962 if (k == M_WRITE 2963 && !gfc_check_vardef_context (e, false, false, false, 2964 _("internal unit in WRITE"))) 2965 return false; 2966 } 2967 2968 if (e->rank && e->ts.type != BT_CHARACTER) 2969 { 2970 gfc_error ("External IO UNIT cannot be an array at %L", &e->where); 2971 return false; 2972 } 2973 2974 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER 2975 && mpz_sgn (e->value.integer) < 0) 2976 { 2977 gfc_error ("UNIT number in statement at %L must be non-negative", 2978 &e->where); 2979 return false; 2980 } 2981 2982 /* If we are reading and have a namelist, check that all namelist symbols 2983 can appear in a variable definition context. */ 2984 if (k == M_READ && dt->namelist) 2985 { 2986 gfc_namelist* n; 2987 for (n = dt->namelist->namelist; n; n = n->next) 2988 { 2989 gfc_expr* e; 2990 bool t; 2991 2992 e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); 2993 t = gfc_check_vardef_context (e, false, false, false, NULL); 2994 gfc_free_expr (e); 2995 2996 if (!t) 2997 { 2998 gfc_error ("NAMELIST %qs in READ statement at %L contains" 2999 " the symbol %qs which may not appear in a" 3000 " variable definition context", 3001 dt->namelist->name, loc, n->sym->name); 3002 return false; 3003 } 3004 } 3005 } 3006 3007 if (dt->extra_comma 3008 && !gfc_notify_std (GFC_STD_GNU, "Comma before i/o item list at %L", 3009 &dt->extra_comma->where)) 3010 return false; 3011 3012 if (dt->err) 3013 { 3014 if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET)) 3015 return false; 3016 if (dt->err->defined == ST_LABEL_UNKNOWN) 3017 { 3018 gfc_error ("ERR tag label %d at %L not defined", 3019 dt->err->value, &dt->err_where); 3020 return false; 3021 } 3022 } 3023 3024 if (dt->end) 3025 { 3026 if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET)) 3027 return false; 3028 if (dt->end->defined == ST_LABEL_UNKNOWN) 3029 { 3030 gfc_error ("END tag label %d at %L not defined", 3031 dt->end->value, &dt->end_where); 3032 return false; 3033 } 3034 } 3035 3036 if (dt->eor) 3037 { 3038 if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET)) 3039 return false; 3040 if (dt->eor->defined == ST_LABEL_UNKNOWN) 3041 { 3042 gfc_error ("EOR tag label %d at %L not defined", 3043 dt->eor->value, &dt->eor_where); 3044 return false; 3045 } 3046 } 3047 3048 /* Check the format label actually exists. */ 3049 if (dt->format_label && dt->format_label != &format_asterisk 3050 && dt->format_label->defined == ST_LABEL_UNKNOWN) 3051 { 3052 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value, 3053 &dt->format_label->where); 3054 return false; 3055 } 3056 3057 return true; 3058} 3059 3060 3061/* Given an io_kind, return its name. */ 3062 3063static const char * 3064io_kind_name (io_kind k) 3065{ 3066 const char *name; 3067 3068 switch (k) 3069 { 3070 case M_READ: 3071 name = "READ"; 3072 break; 3073 case M_WRITE: 3074 name = "WRITE"; 3075 break; 3076 case M_PRINT: 3077 name = "PRINT"; 3078 break; 3079 case M_INQUIRE: 3080 name = "INQUIRE"; 3081 break; 3082 default: 3083 gfc_internal_error ("io_kind_name(): bad I/O-kind"); 3084 } 3085 3086 return name; 3087} 3088 3089 3090/* Match an IO iteration statement of the form: 3091 3092 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] ) 3093 3094 which is equivalent to a single IO element. This function is 3095 mutually recursive with match_io_element(). */ 3096 3097static match match_io_element (io_kind, gfc_code **); 3098 3099static match 3100match_io_iterator (io_kind k, gfc_code **result) 3101{ 3102 gfc_code *head, *tail, *new_code; 3103 gfc_iterator *iter; 3104 locus old_loc; 3105 match m; 3106 int n; 3107 3108 iter = NULL; 3109 head = NULL; 3110 old_loc = gfc_current_locus; 3111 3112 if (gfc_match_char ('(') != MATCH_YES) 3113 return MATCH_NO; 3114 3115 m = match_io_element (k, &head); 3116 tail = head; 3117 3118 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES) 3119 { 3120 m = MATCH_NO; 3121 goto cleanup; 3122 } 3123 3124 /* Can't be anything but an IO iterator. Build a list. */ 3125 iter = gfc_get_iterator (); 3126 3127 for (n = 1;; n++) 3128 { 3129 m = gfc_match_iterator (iter, 0); 3130 if (m == MATCH_ERROR) 3131 goto cleanup; 3132 if (m == MATCH_YES) 3133 { 3134 gfc_check_do_variable (iter->var->symtree); 3135 break; 3136 } 3137 3138 m = match_io_element (k, &new_code); 3139 if (m == MATCH_ERROR) 3140 goto cleanup; 3141 if (m == MATCH_NO) 3142 { 3143 if (n > 2) 3144 goto syntax; 3145 goto cleanup; 3146 } 3147 3148 tail = gfc_append_code (tail, new_code); 3149 3150 if (gfc_match_char (',') != MATCH_YES) 3151 { 3152 if (n > 2) 3153 goto syntax; 3154 m = MATCH_NO; 3155 goto cleanup; 3156 } 3157 } 3158 3159 if (gfc_match_char (')') != MATCH_YES) 3160 goto syntax; 3161 3162 new_code = gfc_get_code (EXEC_DO); 3163 new_code->ext.iterator = iter; 3164 3165 new_code->block = gfc_get_code (EXEC_DO); 3166 new_code->block->next = head; 3167 3168 *result = new_code; 3169 return MATCH_YES; 3170 3171syntax: 3172 gfc_error ("Syntax error in I/O iterator at %C"); 3173 m = MATCH_ERROR; 3174 3175cleanup: 3176 gfc_free_iterator (iter, 1); 3177 gfc_free_statements (head); 3178 gfc_current_locus = old_loc; 3179 return m; 3180} 3181 3182 3183/* Match a single element of an IO list, which is either a single 3184 expression or an IO Iterator. */ 3185 3186static match 3187match_io_element (io_kind k, gfc_code **cpp) 3188{ 3189 gfc_expr *expr; 3190 gfc_code *cp; 3191 match m; 3192 3193 expr = NULL; 3194 3195 m = match_io_iterator (k, cpp); 3196 if (m == MATCH_YES) 3197 return MATCH_YES; 3198 3199 if (k == M_READ) 3200 { 3201 m = gfc_match_variable (&expr, 0); 3202 if (m == MATCH_NO) 3203 gfc_error ("Expected variable in READ statement at %C"); 3204 } 3205 else 3206 { 3207 m = gfc_match_expr (&expr); 3208 if (m == MATCH_NO) 3209 gfc_error ("Expected expression in %s statement at %C", 3210 io_kind_name (k)); 3211 } 3212 3213 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree)) 3214 m = MATCH_ERROR; 3215 3216 if (m != MATCH_YES) 3217 { 3218 gfc_free_expr (expr); 3219 return MATCH_ERROR; 3220 } 3221 3222 cp = gfc_get_code (EXEC_TRANSFER); 3223 cp->expr1 = expr; 3224 if (k != M_INQUIRE) 3225 cp->ext.dt = current_dt; 3226 3227 *cpp = cp; 3228 return MATCH_YES; 3229} 3230 3231 3232/* Match an I/O list, building gfc_code structures as we go. */ 3233 3234static match 3235match_io_list (io_kind k, gfc_code **head_p) 3236{ 3237 gfc_code *head, *tail, *new_code; 3238 match m; 3239 3240 *head_p = head = tail = NULL; 3241 if (gfc_match_eos () == MATCH_YES) 3242 return MATCH_YES; 3243 3244 for (;;) 3245 { 3246 m = match_io_element (k, &new_code); 3247 if (m == MATCH_ERROR) 3248 goto cleanup; 3249 if (m == MATCH_NO) 3250 goto syntax; 3251 3252 tail = gfc_append_code (tail, new_code); 3253 if (head == NULL) 3254 head = new_code; 3255 3256 if (gfc_match_eos () == MATCH_YES) 3257 break; 3258 if (gfc_match_char (',') != MATCH_YES) 3259 goto syntax; 3260 } 3261 3262 *head_p = head; 3263 return MATCH_YES; 3264 3265syntax: 3266 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); 3267 3268cleanup: 3269 gfc_free_statements (head); 3270 return MATCH_ERROR; 3271} 3272 3273 3274/* Attach the data transfer end node. */ 3275 3276static void 3277terminate_io (gfc_code *io_code) 3278{ 3279 gfc_code *c; 3280 3281 if (io_code == NULL) 3282 io_code = new_st.block; 3283 3284 c = gfc_get_code (EXEC_DT_END); 3285 3286 /* Point to structure that is already there */ 3287 c->ext.dt = new_st.ext.dt; 3288 gfc_append_code (io_code, c); 3289} 3290 3291 3292/* Check the constraints for a data transfer statement. The majority of the 3293 constraints appearing in 9.4 of the standard appear here. Some are handled 3294 in resolve_tag and others in gfc_resolve_dt. */ 3295 3296static match 3297check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, 3298 locus *spec_end) 3299{ 3300#define io_constraint(condition,msg,arg)\ 3301if (condition) \ 3302 {\ 3303 gfc_error(msg,arg);\ 3304 m = MATCH_ERROR;\ 3305 } 3306 3307 match m; 3308 gfc_expr *expr; 3309 gfc_symbol *sym = NULL; 3310 bool warn, unformatted; 3311 3312 warn = (dt->err || dt->iostat) ? true : false; 3313 unformatted = dt->format_expr == NULL && dt->format_label == NULL 3314 && dt->namelist == NULL; 3315 3316 m = MATCH_YES; 3317 3318 expr = dt->io_unit; 3319 if (expr && expr->expr_type == EXPR_VARIABLE 3320 && expr->ts.type == BT_CHARACTER) 3321 { 3322 sym = expr->symtree->n.sym; 3323 3324 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN, 3325 "Internal file at %L must not be INTENT(IN)", 3326 &expr->where); 3327 3328 io_constraint (gfc_has_vector_index (dt->io_unit), 3329 "Internal file incompatible with vector subscript at %L", 3330 &expr->where); 3331 3332 io_constraint (dt->rec != NULL, 3333 "REC tag at %L is incompatible with internal file", 3334 &dt->rec->where); 3335 3336 io_constraint (dt->pos != NULL, 3337 "POS tag at %L is incompatible with internal file", 3338 &dt->pos->where); 3339 3340 io_constraint (unformatted, 3341 "Unformatted I/O not allowed with internal unit at %L", 3342 &dt->io_unit->where); 3343 3344 io_constraint (dt->asynchronous != NULL, 3345 "ASYNCHRONOUS tag at %L not allowed with internal file", 3346 &dt->asynchronous->where); 3347 3348 if (dt->namelist != NULL) 3349 { 3350 if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " 3351 "namelist", &expr->where)) 3352 m = MATCH_ERROR; 3353 } 3354 3355 io_constraint (dt->advance != NULL, 3356 "ADVANCE tag at %L is incompatible with internal file", 3357 &dt->advance->where); 3358 } 3359 3360 if (expr && expr->ts.type != BT_CHARACTER) 3361 { 3362 3363 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE), 3364 "IO UNIT in %s statement at %C must be " 3365 "an internal file in a PURE procedure", 3366 io_kind_name (k)); 3367 3368 if (k == M_READ || k == M_WRITE) 3369 gfc_unset_implicit_pure (NULL); 3370 } 3371 3372 if (k != M_READ) 3373 { 3374 io_constraint (dt->end, "END tag not allowed with output at %L", 3375 &dt->end_where); 3376 3377 io_constraint (dt->eor, "EOR tag not allowed with output at %L", 3378 &dt->eor_where); 3379 3380 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L", 3381 &dt->blank->where); 3382 3383 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", 3384 &dt->pad->where); 3385 3386 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", 3387 &dt->size->where); 3388 } 3389 else 3390 { 3391 io_constraint (dt->size && dt->advance == NULL, 3392 "SIZE tag at %L requires an ADVANCE tag", 3393 &dt->size->where); 3394 3395 io_constraint (dt->eor && dt->advance == NULL, 3396 "EOR tag at %L requires an ADVANCE tag", 3397 &dt->eor_where); 3398 } 3399 3400 if (dt->asynchronous) 3401 { 3402 static const char * asynchronous[] = { "YES", "NO", NULL }; 3403 3404 if (!gfc_reduce_init_expr (dt->asynchronous)) 3405 { 3406 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization " 3407 "expression", &dt->asynchronous->where); 3408 return MATCH_ERROR; 3409 } 3410 3411 if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous)) 3412 return MATCH_ERROR; 3413 3414 if (!compare_to_allowed_values 3415 ("ASYNCHRONOUS", asynchronous, NULL, NULL, 3416 dt->asynchronous->value.character.string, 3417 io_kind_name (k), warn)) 3418 return MATCH_ERROR; 3419 } 3420 3421 if (dt->id) 3422 { 3423 bool not_yes 3424 = !dt->asynchronous 3425 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 3426 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, 3427 "yes", 3) != 0; 3428 io_constraint (not_yes, 3429 "ID= specifier at %L must be with ASYNCHRONOUS='yes' " 3430 "specifier", &dt->id->where); 3431 } 3432 3433 if (dt->decimal) 3434 { 3435 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " 3436 "not allowed in Fortran 95")) 3437 return MATCH_ERROR; 3438 3439 if (dt->decimal->expr_type == EXPR_CONSTANT) 3440 { 3441 static const char * decimal[] = { "COMMA", "POINT", NULL }; 3442 3443 if (!is_char_type ("DECIMAL", dt->decimal)) 3444 return MATCH_ERROR; 3445 3446 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, 3447 dt->decimal->value.character.string, 3448 io_kind_name (k), warn)) 3449 return MATCH_ERROR; 3450 3451 io_constraint (unformatted, 3452 "the DECIMAL= specifier at %L must be with an " 3453 "explicit format expression", &dt->decimal->where); 3454 } 3455 } 3456 3457 if (dt->blank) 3458 { 3459 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " 3460 "not allowed in Fortran 95")) 3461 return MATCH_ERROR; 3462 3463 if (!is_char_type ("BLANK", dt->blank)) 3464 return MATCH_ERROR; 3465 3466 if (dt->blank->expr_type == EXPR_CONSTANT) 3467 { 3468 static const char * blank[] = { "NULL", "ZERO", NULL }; 3469 3470 3471 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, 3472 dt->blank->value.character.string, 3473 io_kind_name (k), warn)) 3474 return MATCH_ERROR; 3475 3476 io_constraint (unformatted, 3477 "the BLANK= specifier at %L must be with an " 3478 "explicit format expression", &dt->blank->where); 3479 } 3480 } 3481 3482 if (dt->pad) 3483 { 3484 if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C " 3485 "not allowed in Fortran 95")) 3486 return MATCH_ERROR; 3487 3488 if (!is_char_type ("PAD", dt->pad)) 3489 return MATCH_ERROR; 3490 3491 if (dt->pad->expr_type == EXPR_CONSTANT) 3492 { 3493 static const char * pad[] = { "YES", "NO", NULL }; 3494 3495 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, 3496 dt->pad->value.character.string, 3497 io_kind_name (k), warn)) 3498 return MATCH_ERROR; 3499 3500 io_constraint (unformatted, 3501 "the PAD= specifier at %L must be with an " 3502 "explicit format expression", &dt->pad->where); 3503 } 3504 } 3505 3506 if (dt->round) 3507 { 3508 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " 3509 "not allowed in Fortran 95")) 3510 return MATCH_ERROR; 3511 3512 if (!is_char_type ("ROUND", dt->round)) 3513 return MATCH_ERROR; 3514 3515 if (dt->round->expr_type == EXPR_CONSTANT) 3516 { 3517 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", 3518 "COMPATIBLE", "PROCESSOR_DEFINED", 3519 NULL }; 3520 3521 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, 3522 dt->round->value.character.string, 3523 io_kind_name (k), warn)) 3524 return MATCH_ERROR; 3525 } 3526 } 3527 3528 if (dt->sign) 3529 { 3530 /* When implemented, change the following to use gfc_notify_std F2003. 3531 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " 3532 "not allowed in Fortran 95") == false) 3533 return MATCH_ERROR; */ 3534 3535 if (!is_char_type ("SIGN", dt->sign)) 3536 return MATCH_ERROR; 3537 3538 if (dt->sign->expr_type == EXPR_CONSTANT) 3539 { 3540 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", 3541 NULL }; 3542 3543 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, 3544 dt->sign->value.character.string, 3545 io_kind_name (k), warn)) 3546 return MATCH_ERROR; 3547 3548 io_constraint (unformatted, 3549 "SIGN= specifier at %L must be with an " 3550 "explicit format expression", &dt->sign->where); 3551 3552 io_constraint (k == M_READ, 3553 "SIGN= specifier at %L not allowed in a " 3554 "READ statement", &dt->sign->where); 3555 } 3556 } 3557 3558 if (dt->delim) 3559 { 3560 if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C " 3561 "not allowed in Fortran 95")) 3562 return MATCH_ERROR; 3563 3564 if (!is_char_type ("DELIM", dt->delim)) 3565 return MATCH_ERROR; 3566 3567 if (dt->delim->expr_type == EXPR_CONSTANT) 3568 { 3569 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; 3570 3571 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, 3572 dt->delim->value.character.string, 3573 io_kind_name (k), warn)) 3574 return MATCH_ERROR; 3575 3576 io_constraint (k == M_READ, 3577 "DELIM= specifier at %L not allowed in a " 3578 "READ statement", &dt->delim->where); 3579 3580 io_constraint (dt->format_label != &format_asterisk 3581 && dt->namelist == NULL, 3582 "DELIM= specifier at %L must have FMT=*", 3583 &dt->delim->where); 3584 3585 io_constraint (unformatted && dt->namelist == NULL, 3586 "DELIM= specifier at %L must be with FMT=* or " 3587 "NML= specifier ", &dt->delim->where); 3588 } 3589 } 3590 3591 if (dt->namelist) 3592 { 3593 io_constraint (io_code && dt->namelist, 3594 "NAMELIST cannot be followed by IO-list at %L", 3595 &io_code->loc); 3596 3597 io_constraint (dt->format_expr, 3598 "IO spec-list cannot contain both NAMELIST group name " 3599 "and format specification at %L", 3600 &dt->format_expr->where); 3601 3602 io_constraint (dt->format_label, 3603 "IO spec-list cannot contain both NAMELIST group name " 3604 "and format label at %L", spec_end); 3605 3606 io_constraint (dt->rec, 3607 "NAMELIST IO is not allowed with a REC= specifier " 3608 "at %L", &dt->rec->where); 3609 3610 io_constraint (dt->advance, 3611 "NAMELIST IO is not allowed with a ADVANCE= specifier " 3612 "at %L", &dt->advance->where); 3613 } 3614 3615 if (dt->rec) 3616 { 3617 io_constraint (dt->end, 3618 "An END tag is not allowed with a " 3619 "REC= specifier at %L", &dt->end_where); 3620 3621 io_constraint (dt->format_label == &format_asterisk, 3622 "FMT=* is not allowed with a REC= specifier " 3623 "at %L", spec_end); 3624 3625 io_constraint (dt->pos, 3626 "POS= is not allowed with REC= specifier " 3627 "at %L", &dt->pos->where); 3628 } 3629 3630 if (dt->advance) 3631 { 3632 int not_yes, not_no; 3633 expr = dt->advance; 3634 3635 io_constraint (dt->format_label == &format_asterisk, 3636 "List directed format(*) is not allowed with a " 3637 "ADVANCE= specifier at %L.", &expr->where); 3638 3639 io_constraint (unformatted, 3640 "the ADVANCE= specifier at %L must appear with an " 3641 "explicit format expression", &expr->where); 3642 3643 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) 3644 { 3645 const gfc_char_t *advance = expr->value.character.string; 3646 not_no = gfc_wide_strlen (advance) != 2 3647 || gfc_wide_strncasecmp (advance, "no", 2) != 0; 3648 not_yes = gfc_wide_strlen (advance) != 3 3649 || gfc_wide_strncasecmp (advance, "yes", 3) != 0; 3650 } 3651 else 3652 { 3653 not_no = 0; 3654 not_yes = 0; 3655 } 3656 3657 io_constraint (not_no && not_yes, 3658 "ADVANCE= specifier at %L must have value = " 3659 "YES or NO.", &expr->where); 3660 3661 io_constraint (dt->size && not_no && k == M_READ, 3662 "SIZE tag at %L requires an ADVANCE = %<NO%>", 3663 &dt->size->where); 3664 3665 io_constraint (dt->eor && not_no && k == M_READ, 3666 "EOR tag at %L requires an ADVANCE = %<NO%>", 3667 &dt->eor_where); 3668 } 3669 3670 expr = dt->format_expr; 3671 if (!gfc_simplify_expr (expr, 0) 3672 || !check_format_string (expr, k == M_READ)) 3673 return MATCH_ERROR; 3674 3675 return m; 3676} 3677#undef io_constraint 3678 3679 3680/* Match a READ, WRITE or PRINT statement. */ 3681 3682static match 3683match_io (io_kind k) 3684{ 3685 char name[GFC_MAX_SYMBOL_LEN + 1]; 3686 gfc_code *io_code; 3687 gfc_symbol *sym; 3688 int comma_flag; 3689 locus where; 3690 locus spec_end; 3691 gfc_dt *dt; 3692 match m; 3693 3694 where = gfc_current_locus; 3695 comma_flag = 0; 3696 current_dt = dt = XCNEW (gfc_dt); 3697 m = gfc_match_char ('('); 3698 if (m == MATCH_NO) 3699 { 3700 where = gfc_current_locus; 3701 if (k == M_WRITE) 3702 goto syntax; 3703 else if (k == M_PRINT) 3704 { 3705 /* Treat the non-standard case of PRINT namelist. */ 3706 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') 3707 && gfc_match_name (name) == MATCH_YES) 3708 { 3709 gfc_find_symbol (name, NULL, 1, &sym); 3710 if (sym && sym->attr.flavor == FL_NAMELIST) 3711 { 3712 if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at " 3713 "%C is an extension")) 3714 { 3715 m = MATCH_ERROR; 3716 goto cleanup; 3717 } 3718 3719 dt->io_unit = default_unit (k); 3720 dt->namelist = sym; 3721 goto get_io_list; 3722 } 3723 else 3724 gfc_current_locus = where; 3725 } 3726 } 3727 3728 if (gfc_current_form == FORM_FREE) 3729 { 3730 char c = gfc_peek_ascii_char (); 3731 if (c != ' ' && c != '*' && c != '\'' && c != '"') 3732 { 3733 m = MATCH_NO; 3734 goto cleanup; 3735 } 3736 } 3737 3738 m = match_dt_format (dt); 3739 if (m == MATCH_ERROR) 3740 goto cleanup; 3741 if (m == MATCH_NO) 3742 goto syntax; 3743 3744 comma_flag = 1; 3745 dt->io_unit = default_unit (k); 3746 goto get_io_list; 3747 } 3748 else 3749 { 3750 /* Before issuing an error for a malformed 'print (1,*)' type of 3751 error, check for a default-char-expr of the form ('(I0)'). */ 3752 if (k == M_PRINT && m == MATCH_YES) 3753 { 3754 /* Reset current locus to get the initial '(' in an expression. */ 3755 gfc_current_locus = where; 3756 dt->format_expr = NULL; 3757 m = match_dt_format (dt); 3758 3759 if (m == MATCH_ERROR) 3760 goto cleanup; 3761 if (m == MATCH_NO || dt->format_expr == NULL) 3762 goto syntax; 3763 3764 comma_flag = 1; 3765 dt->io_unit = default_unit (k); 3766 goto get_io_list; 3767 } 3768 } 3769 3770 /* Match a control list */ 3771 if (match_dt_element (k, dt) == MATCH_YES) 3772 goto next; 3773 if (match_dt_unit (k, dt) != MATCH_YES) 3774 goto loop; 3775 3776 if (gfc_match_char (')') == MATCH_YES) 3777 goto get_io_list; 3778 if (gfc_match_char (',') != MATCH_YES) 3779 goto syntax; 3780 3781 m = match_dt_element (k, dt); 3782 if (m == MATCH_YES) 3783 goto next; 3784 if (m == MATCH_ERROR) 3785 goto cleanup; 3786 3787 m = match_dt_format (dt); 3788 if (m == MATCH_YES) 3789 goto next; 3790 if (m == MATCH_ERROR) 3791 goto cleanup; 3792 3793 where = gfc_current_locus; 3794 3795 m = gfc_match_name (name); 3796 if (m == MATCH_YES) 3797 { 3798 gfc_find_symbol (name, NULL, 1, &sym); 3799 if (sym && sym->attr.flavor == FL_NAMELIST) 3800 { 3801 dt->namelist = sym; 3802 if (k == M_READ && check_namelist (sym)) 3803 { 3804 m = MATCH_ERROR; 3805 goto cleanup; 3806 } 3807 goto next; 3808 } 3809 } 3810 3811 gfc_current_locus = where; 3812 3813 goto loop; /* No matches, try regular elements */ 3814 3815next: 3816 if (gfc_match_char (')') == MATCH_YES) 3817 goto get_io_list; 3818 if (gfc_match_char (',') != MATCH_YES) 3819 goto syntax; 3820 3821loop: 3822 for (;;) 3823 { 3824 m = match_dt_element (k, dt); 3825 if (m == MATCH_NO) 3826 goto syntax; 3827 if (m == MATCH_ERROR) 3828 goto cleanup; 3829 3830 if (gfc_match_char (')') == MATCH_YES) 3831 break; 3832 if (gfc_match_char (',') != MATCH_YES) 3833 goto syntax; 3834 } 3835 3836get_io_list: 3837 3838 /* Used in check_io_constraints, where no locus is available. */ 3839 spec_end = gfc_current_locus; 3840 3841 /* Save the IO kind for later use. */ 3842 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); 3843 3844 /* Optional leading comma (non-standard). We use a gfc_expr structure here 3845 to save the locus. This is used later when resolving transfer statements 3846 that might have a format expression without unit number. */ 3847 if (!comma_flag && gfc_match_char (',') == MATCH_YES) 3848 dt->extra_comma = dt->dt_io_kind; 3849 3850 io_code = NULL; 3851 if (gfc_match_eos () != MATCH_YES) 3852 { 3853 if (comma_flag && gfc_match_char (',') != MATCH_YES) 3854 { 3855 gfc_error ("Expected comma in I/O list at %C"); 3856 m = MATCH_ERROR; 3857 goto cleanup; 3858 } 3859 3860 m = match_io_list (k, &io_code); 3861 if (m == MATCH_ERROR) 3862 goto cleanup; 3863 if (m == MATCH_NO) 3864 goto syntax; 3865 } 3866 3867 /* A full IO statement has been matched. Check the constraints. spec_end is 3868 supplied for cases where no locus is supplied. */ 3869 m = check_io_constraints (k, dt, io_code, &spec_end); 3870 3871 if (m == MATCH_ERROR) 3872 goto cleanup; 3873 3874 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; 3875 new_st.ext.dt = dt; 3876 new_st.block = gfc_get_code (new_st.op); 3877 new_st.block->next = io_code; 3878 3879 terminate_io (io_code); 3880 3881 return MATCH_YES; 3882 3883syntax: 3884 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); 3885 m = MATCH_ERROR; 3886 3887cleanup: 3888 gfc_free_dt (dt); 3889 return m; 3890} 3891 3892 3893match 3894gfc_match_read (void) 3895{ 3896 return match_io (M_READ); 3897} 3898 3899 3900match 3901gfc_match_write (void) 3902{ 3903 return match_io (M_WRITE); 3904} 3905 3906 3907match 3908gfc_match_print (void) 3909{ 3910 match m; 3911 3912 m = match_io (M_PRINT); 3913 if (m != MATCH_YES) 3914 return m; 3915 3916 if (gfc_pure (NULL)) 3917 { 3918 gfc_error ("PRINT statement at %C not allowed within PURE procedure"); 3919 return MATCH_ERROR; 3920 } 3921 3922 gfc_unset_implicit_pure (NULL); 3923 3924 return MATCH_YES; 3925} 3926 3927 3928/* Free a gfc_inquire structure. */ 3929 3930void 3931gfc_free_inquire (gfc_inquire *inquire) 3932{ 3933 3934 if (inquire == NULL) 3935 return; 3936 3937 gfc_free_expr (inquire->unit); 3938 gfc_free_expr (inquire->file); 3939 gfc_free_expr (inquire->iomsg); 3940 gfc_free_expr (inquire->iostat); 3941 gfc_free_expr (inquire->exist); 3942 gfc_free_expr (inquire->opened); 3943 gfc_free_expr (inquire->number); 3944 gfc_free_expr (inquire->named); 3945 gfc_free_expr (inquire->name); 3946 gfc_free_expr (inquire->access); 3947 gfc_free_expr (inquire->sequential); 3948 gfc_free_expr (inquire->direct); 3949 gfc_free_expr (inquire->form); 3950 gfc_free_expr (inquire->formatted); 3951 gfc_free_expr (inquire->unformatted); 3952 gfc_free_expr (inquire->recl); 3953 gfc_free_expr (inquire->nextrec); 3954 gfc_free_expr (inquire->blank); 3955 gfc_free_expr (inquire->position); 3956 gfc_free_expr (inquire->action); 3957 gfc_free_expr (inquire->read); 3958 gfc_free_expr (inquire->write); 3959 gfc_free_expr (inquire->readwrite); 3960 gfc_free_expr (inquire->delim); 3961 gfc_free_expr (inquire->encoding); 3962 gfc_free_expr (inquire->pad); 3963 gfc_free_expr (inquire->iolength); 3964 gfc_free_expr (inquire->convert); 3965 gfc_free_expr (inquire->strm_pos); 3966 gfc_free_expr (inquire->asynchronous); 3967 gfc_free_expr (inquire->decimal); 3968 gfc_free_expr (inquire->pending); 3969 gfc_free_expr (inquire->id); 3970 gfc_free_expr (inquire->sign); 3971 gfc_free_expr (inquire->size); 3972 gfc_free_expr (inquire->round); 3973 free (inquire); 3974} 3975 3976 3977/* Match an element of an INQUIRE statement. */ 3978 3979#define RETM if (m != MATCH_NO) return m; 3980 3981static match 3982match_inquire_element (gfc_inquire *inquire) 3983{ 3984 match m; 3985 3986 m = match_etag (&tag_unit, &inquire->unit); 3987 RETM m = match_etag (&tag_file, &inquire->file); 3988 RETM m = match_ltag (&tag_err, &inquire->err); 3989 RETM m = match_etag (&tag_iomsg, &inquire->iomsg); 3990 if (m == MATCH_YES && !check_char_variable (inquire->iomsg)) 3991 return MATCH_ERROR; 3992 RETM m = match_out_tag (&tag_iostat, &inquire->iostat); 3993 RETM m = match_vtag (&tag_exist, &inquire->exist); 3994 RETM m = match_vtag (&tag_opened, &inquire->opened); 3995 RETM m = match_vtag (&tag_named, &inquire->named); 3996 RETM m = match_vtag (&tag_name, &inquire->name); 3997 RETM m = match_out_tag (&tag_number, &inquire->number); 3998 RETM m = match_vtag (&tag_s_access, &inquire->access); 3999 RETM m = match_vtag (&tag_sequential, &inquire->sequential); 4000 RETM m = match_vtag (&tag_direct, &inquire->direct); 4001 RETM m = match_vtag (&tag_s_form, &inquire->form); 4002 RETM m = match_vtag (&tag_formatted, &inquire->formatted); 4003 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); 4004 RETM m = match_out_tag (&tag_s_recl, &inquire->recl); 4005 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec); 4006 RETM m = match_vtag (&tag_s_blank, &inquire->blank); 4007 RETM m = match_vtag (&tag_s_position, &inquire->position); 4008 RETM m = match_vtag (&tag_s_action, &inquire->action); 4009 RETM m = match_vtag (&tag_read, &inquire->read); 4010 RETM m = match_vtag (&tag_write, &inquire->write); 4011 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); 4012 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); 4013 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", inquire->asynchronous)) 4014 return MATCH_ERROR; 4015 RETM m = match_vtag (&tag_s_delim, &inquire->delim); 4016 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); 4017 RETM m = match_out_tag (&tag_size, &inquire->size); 4018 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding); 4019 RETM m = match_vtag (&tag_s_round, &inquire->round); 4020 RETM m = match_vtag (&tag_s_sign, &inquire->sign); 4021 RETM m = match_vtag (&tag_s_pad, &inquire->pad); 4022 RETM m = match_out_tag (&tag_iolength, &inquire->iolength); 4023 RETM m = match_vtag (&tag_convert, &inquire->convert); 4024 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos); 4025 RETM m = match_vtag (&tag_pending, &inquire->pending); 4026 RETM m = match_vtag (&tag_id, &inquire->id); 4027 RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream); 4028 RETM return MATCH_NO; 4029} 4030 4031#undef RETM 4032 4033 4034match 4035gfc_match_inquire (void) 4036{ 4037 gfc_inquire *inquire; 4038 gfc_code *code; 4039 match m; 4040 locus loc; 4041 4042 m = gfc_match_char ('('); 4043 if (m == MATCH_NO) 4044 return m; 4045 4046 inquire = XCNEW (gfc_inquire); 4047 4048 loc = gfc_current_locus; 4049 4050 m = match_inquire_element (inquire); 4051 if (m == MATCH_ERROR) 4052 goto cleanup; 4053 if (m == MATCH_NO) 4054 { 4055 m = gfc_match_expr (&inquire->unit); 4056 if (m == MATCH_ERROR) 4057 goto cleanup; 4058 if (m == MATCH_NO) 4059 goto syntax; 4060 } 4061 4062 /* See if we have the IOLENGTH form of the inquire statement. */ 4063 if (inquire->iolength != NULL) 4064 { 4065 if (gfc_match_char (')') != MATCH_YES) 4066 goto syntax; 4067 4068 m = match_io_list (M_INQUIRE, &code); 4069 if (m == MATCH_ERROR) 4070 goto cleanup; 4071 if (m == MATCH_NO) 4072 goto syntax; 4073 4074 new_st.op = EXEC_IOLENGTH; 4075 new_st.expr1 = inquire->iolength; 4076 new_st.ext.inquire = inquire; 4077 4078 if (gfc_pure (NULL)) 4079 { 4080 gfc_free_statements (code); 4081 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); 4082 return MATCH_ERROR; 4083 } 4084 4085 gfc_unset_implicit_pure (NULL); 4086 4087 new_st.block = gfc_get_code (EXEC_IOLENGTH); 4088 terminate_io (code); 4089 new_st.block->next = code; 4090 return MATCH_YES; 4091 } 4092 4093 /* At this point, we have the non-IOLENGTH inquire statement. */ 4094 for (;;) 4095 { 4096 if (gfc_match_char (')') == MATCH_YES) 4097 break; 4098 if (gfc_match_char (',') != MATCH_YES) 4099 goto syntax; 4100 4101 m = match_inquire_element (inquire); 4102 if (m == MATCH_ERROR) 4103 goto cleanup; 4104 if (m == MATCH_NO) 4105 goto syntax; 4106 4107 if (inquire->iolength != NULL) 4108 { 4109 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C"); 4110 goto cleanup; 4111 } 4112 } 4113 4114 if (gfc_match_eos () != MATCH_YES) 4115 goto syntax; 4116 4117 if (inquire->unit != NULL && inquire->file != NULL) 4118 { 4119 gfc_error ("INQUIRE statement at %L cannot contain both FILE and " 4120 "UNIT specifiers", &loc); 4121 goto cleanup; 4122 } 4123 4124 if (inquire->unit == NULL && inquire->file == NULL) 4125 { 4126 gfc_error ("INQUIRE statement at %L requires either FILE or " 4127 "UNIT specifier", &loc); 4128 goto cleanup; 4129 } 4130 4131 if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT 4132 && inquire->unit->ts.type == BT_INTEGER 4133 && mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT) 4134 { 4135 gfc_error ("UNIT number in INQUIRE statement at %L can not be -1", &loc); 4136 goto cleanup; 4137 } 4138 4139 if (gfc_pure (NULL)) 4140 { 4141 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); 4142 goto cleanup; 4143 } 4144 4145 gfc_unset_implicit_pure (NULL); 4146 4147 if (inquire->id != NULL && inquire->pending == NULL) 4148 { 4149 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with " 4150 "the ID= specifier", &loc); 4151 goto cleanup; 4152 } 4153 4154 new_st.op = EXEC_INQUIRE; 4155 new_st.ext.inquire = inquire; 4156 return MATCH_YES; 4157 4158syntax: 4159 gfc_syntax_error (ST_INQUIRE); 4160 4161cleanup: 4162 gfc_free_inquire (inquire); 4163 return MATCH_ERROR; 4164} 4165 4166 4167/* Resolve everything in a gfc_inquire structure. */ 4168 4169bool 4170gfc_resolve_inquire (gfc_inquire *inquire) 4171{ 4172 RESOLVE_TAG (&tag_unit, inquire->unit); 4173 RESOLVE_TAG (&tag_file, inquire->file); 4174 RESOLVE_TAG (&tag_id, inquire->id); 4175 4176 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition 4177 contexts. Thus, use an extended RESOLVE_TAG macro for that. */ 4178#define INQUIRE_RESOLVE_TAG(tag, expr) \ 4179 RESOLVE_TAG (tag, expr); \ 4180 if (expr) \ 4181 { \ 4182 char context[64]; \ 4183 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \ 4184 if (gfc_check_vardef_context ((expr), false, false, false, \ 4185 context) == false) \ 4186 return false; \ 4187 } 4188 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg); 4189 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat); 4190 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist); 4191 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened); 4192 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number); 4193 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named); 4194 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name); 4195 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access); 4196 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential); 4197 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct); 4198 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form); 4199 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted); 4200 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted); 4201 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl); 4202 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec); 4203 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank); 4204 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position); 4205 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action); 4206 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read); 4207 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write); 4208 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite); 4209 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim); 4210 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad); 4211 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding); 4212 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); 4213 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength); 4214 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert); 4215 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); 4216 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous); 4217 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign); 4218 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); 4219 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending); 4220 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); 4221 INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal); 4222 INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream); 4223#undef INQUIRE_RESOLVE_TAG 4224 4225 if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET)) 4226 return false; 4227 4228 return true; 4229} 4230 4231 4232void 4233gfc_free_wait (gfc_wait *wait) 4234{ 4235 if (wait == NULL) 4236 return; 4237 4238 gfc_free_expr (wait->unit); 4239 gfc_free_expr (wait->iostat); 4240 gfc_free_expr (wait->iomsg); 4241 gfc_free_expr (wait->id); 4242 free (wait); 4243} 4244 4245 4246bool 4247gfc_resolve_wait (gfc_wait *wait) 4248{ 4249 RESOLVE_TAG (&tag_unit, wait->unit); 4250 RESOLVE_TAG (&tag_iomsg, wait->iomsg); 4251 RESOLVE_TAG (&tag_iostat, wait->iostat); 4252 RESOLVE_TAG (&tag_id, wait->id); 4253 4254 if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET)) 4255 return false; 4256 4257 if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET)) 4258 return false; 4259 4260 return true; 4261} 4262 4263/* Match an element of a WAIT statement. */ 4264 4265#define RETM if (m != MATCH_NO) return m; 4266 4267static match 4268match_wait_element (gfc_wait *wait) 4269{ 4270 match m; 4271 4272 m = match_etag (&tag_unit, &wait->unit); 4273 RETM m = match_ltag (&tag_err, &wait->err); 4274 RETM m = match_ltag (&tag_end, &wait->eor); 4275 RETM m = match_ltag (&tag_eor, &wait->end); 4276 RETM m = match_etag (&tag_iomsg, &wait->iomsg); 4277 if (m == MATCH_YES && !check_char_variable (wait->iomsg)) 4278 return MATCH_ERROR; 4279 RETM m = match_out_tag (&tag_iostat, &wait->iostat); 4280 RETM m = match_etag (&tag_id, &wait->id); 4281 RETM return MATCH_NO; 4282} 4283 4284#undef RETM 4285 4286 4287match 4288gfc_match_wait (void) 4289{ 4290 gfc_wait *wait; 4291 match m; 4292 4293 m = gfc_match_char ('('); 4294 if (m == MATCH_NO) 4295 return m; 4296 4297 wait = XCNEW (gfc_wait); 4298 4299 m = match_wait_element (wait); 4300 if (m == MATCH_ERROR) 4301 goto cleanup; 4302 if (m == MATCH_NO) 4303 { 4304 m = gfc_match_expr (&wait->unit); 4305 if (m == MATCH_ERROR) 4306 goto cleanup; 4307 if (m == MATCH_NO) 4308 goto syntax; 4309 } 4310 4311 for (;;) 4312 { 4313 if (gfc_match_char (')') == MATCH_YES) 4314 break; 4315 if (gfc_match_char (',') != MATCH_YES) 4316 goto syntax; 4317 4318 m = match_wait_element (wait); 4319 if (m == MATCH_ERROR) 4320 goto cleanup; 4321 if (m == MATCH_NO) 4322 goto syntax; 4323 } 4324 4325 if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C " 4326 "not allowed in Fortran 95")) 4327 goto cleanup; 4328 4329 if (gfc_pure (NULL)) 4330 { 4331 gfc_error ("WAIT statement not allowed in PURE procedure at %C"); 4332 goto cleanup; 4333 } 4334 4335 gfc_unset_implicit_pure (NULL); 4336 4337 new_st.op = EXEC_WAIT; 4338 new_st.ext.wait = wait; 4339 4340 return MATCH_YES; 4341 4342syntax: 4343 gfc_syntax_error (ST_WAIT); 4344 4345cleanup: 4346 gfc_free_wait (wait); 4347 return MATCH_ERROR; 4348} 4349