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