1 /* Main parser. 2 Copyright (C) 2000-2020 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 <setjmp.h> 27 #include "match.h" 28 #include "parse.h" 29 30 /* Current statement label. Zero means no statement label. Because new_st 31 can get wiped during statement matching, we have to keep it separate. */ 32 33 gfc_st_label *gfc_statement_label; 34 35 static locus label_locus; 36 static jmp_buf eof_buf; 37 38 gfc_state_data *gfc_state_stack; 39 static bool last_was_use_stmt = false; 40 41 /* TODO: Re-order functions to kill these forward decls. */ 42 static void check_statement_label (gfc_statement); 43 static void undo_new_statement (void); 44 static void reject_statement (void); 45 46 47 /* A sort of half-matching function. We try to match the word on the 48 input with the passed string. If this succeeds, we call the 49 keyword-dependent matching function that will match the rest of the 50 statement. For single keywords, the matching subroutine is 51 gfc_match_eos(). */ 52 53 static match 54 match_word (const char *str, match (*subr) (void), locus *old_locus) 55 { 56 match m; 57 58 if (str != NULL) 59 { 60 m = gfc_match (str); 61 if (m != MATCH_YES) 62 return m; 63 } 64 65 m = (*subr) (); 66 67 if (m != MATCH_YES) 68 { 69 gfc_current_locus = *old_locus; 70 reject_statement (); 71 } 72 73 return m; 74 } 75 76 77 /* Like match_word, but if str is matched, set a flag that it 78 was matched. */ 79 static match 80 match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus, 81 bool *simd_matched) 82 { 83 match m; 84 85 if (str != NULL) 86 { 87 m = gfc_match (str); 88 if (m != MATCH_YES) 89 return m; 90 *simd_matched = true; 91 } 92 93 m = (*subr) (); 94 95 if (m != MATCH_YES) 96 { 97 gfc_current_locus = *old_locus; 98 reject_statement (); 99 } 100 101 return m; 102 } 103 104 105 /* Load symbols from all USE statements encountered in this scoping unit. */ 106 107 static void 108 use_modules (void) 109 { 110 gfc_error_buffer old_error; 111 112 gfc_push_error (&old_error); 113 gfc_buffer_error (false); 114 gfc_use_modules (); 115 gfc_buffer_error (true); 116 gfc_pop_error (&old_error); 117 gfc_commit_symbols (); 118 gfc_warning_check (); 119 gfc_current_ns->old_equiv = gfc_current_ns->equiv; 120 gfc_current_ns->old_data = gfc_current_ns->data; 121 last_was_use_stmt = false; 122 } 123 124 125 /* Figure out what the next statement is, (mostly) regardless of 126 proper ordering. The do...while(0) is there to prevent if/else 127 ambiguity. */ 128 129 #define match(keyword, subr, st) \ 130 do { \ 131 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \ 132 return st; \ 133 else \ 134 undo_new_statement (); \ 135 } while (0) 136 137 138 /* This is a specialist version of decode_statement that is used 139 for the specification statements in a function, whose 140 characteristics are deferred into the specification statements. 141 eg.: INTEGER (king = mykind) foo () 142 USE mymodule, ONLY mykind..... 143 The KIND parameter needs a return after USE or IMPORT, whereas 144 derived type declarations can occur anywhere, up the executable 145 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run 146 out of the correct kind of specification statements. */ 147 static gfc_statement 148 decode_specification_statement (void) 149 { 150 gfc_statement st; 151 locus old_locus; 152 char c; 153 154 if (gfc_match_eos () == MATCH_YES) 155 return ST_NONE; 156 157 old_locus = gfc_current_locus; 158 159 if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) 160 { 161 last_was_use_stmt = true; 162 return ST_USE; 163 } 164 else 165 { 166 undo_new_statement (); 167 if (last_was_use_stmt) 168 use_modules (); 169 } 170 171 match ("import", gfc_match_import, ST_IMPORT); 172 173 if (gfc_current_block ()->result->ts.type != BT_DERIVED) 174 goto end_of_block; 175 176 match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); 177 match (NULL, gfc_match_data_decl, ST_DATA_DECL); 178 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); 179 180 /* General statement matching: Instead of testing every possible 181 statement, we eliminate most possibilities by peeking at the 182 first character. */ 183 184 c = gfc_peek_ascii_char (); 185 186 switch (c) 187 { 188 case 'a': 189 match ("abstract% interface", gfc_match_abstract_interface, 190 ST_INTERFACE); 191 match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); 192 match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); 193 match ("automatic", gfc_match_automatic, ST_ATTR_DECL); 194 break; 195 196 case 'b': 197 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); 198 break; 199 200 case 'c': 201 match ("codimension", gfc_match_codimension, ST_ATTR_DECL); 202 match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); 203 break; 204 205 case 'd': 206 match ("data", gfc_match_data, ST_DATA); 207 match ("dimension", gfc_match_dimension, ST_ATTR_DECL); 208 break; 209 210 case 'e': 211 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); 212 match ("entry% ", gfc_match_entry, ST_ENTRY); 213 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); 214 match ("external", gfc_match_external, ST_ATTR_DECL); 215 break; 216 217 case 'f': 218 match ("format", gfc_match_format, ST_FORMAT); 219 break; 220 221 case 'g': 222 break; 223 224 case 'i': 225 match ("implicit", gfc_match_implicit, ST_IMPLICIT); 226 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); 227 match ("interface", gfc_match_interface, ST_INTERFACE); 228 match ("intent", gfc_match_intent, ST_ATTR_DECL); 229 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); 230 break; 231 232 case 'm': 233 break; 234 235 case 'n': 236 match ("namelist", gfc_match_namelist, ST_NAMELIST); 237 break; 238 239 case 'o': 240 match ("optional", gfc_match_optional, ST_ATTR_DECL); 241 break; 242 243 case 'p': 244 match ("parameter", gfc_match_parameter, ST_PARAMETER); 245 match ("pointer", gfc_match_pointer, ST_ATTR_DECL); 246 if (gfc_match_private (&st) == MATCH_YES) 247 return st; 248 match ("procedure", gfc_match_procedure, ST_PROCEDURE); 249 if (gfc_match_public (&st) == MATCH_YES) 250 return st; 251 match ("protected", gfc_match_protected, ST_ATTR_DECL); 252 break; 253 254 case 'r': 255 break; 256 257 case 's': 258 match ("save", gfc_match_save, ST_ATTR_DECL); 259 match ("static", gfc_match_static, ST_ATTR_DECL); 260 match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); 261 break; 262 263 case 't': 264 match ("target", gfc_match_target, ST_ATTR_DECL); 265 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); 266 break; 267 268 case 'u': 269 break; 270 271 case 'v': 272 match ("value", gfc_match_value, ST_ATTR_DECL); 273 match ("volatile", gfc_match_volatile, ST_ATTR_DECL); 274 break; 275 276 case 'w': 277 break; 278 } 279 280 /* This is not a specification statement. See if any of the matchers 281 has stored an error message of some sort. */ 282 283 end_of_block: 284 gfc_clear_error (); 285 gfc_buffer_error (false); 286 gfc_current_locus = old_locus; 287 288 return ST_GET_FCN_CHARACTERISTICS; 289 } 290 291 static bool in_specification_block; 292 293 /* This is the primary 'decode_statement'. */ 294 static gfc_statement 295 decode_statement (void) 296 { 297 gfc_statement st; 298 locus old_locus; 299 match m = MATCH_NO; 300 char c; 301 302 gfc_enforce_clean_symbol_state (); 303 304 gfc_clear_error (); /* Clear any pending errors. */ 305 gfc_clear_warning (); /* Clear any pending warnings. */ 306 307 gfc_matching_function = false; 308 309 if (gfc_match_eos () == MATCH_YES) 310 return ST_NONE; 311 312 if (gfc_current_state () == COMP_FUNCTION 313 && gfc_current_block ()->result->ts.kind == -1) 314 return decode_specification_statement (); 315 316 old_locus = gfc_current_locus; 317 318 c = gfc_peek_ascii_char (); 319 320 if (c == 'u') 321 { 322 if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) 323 { 324 last_was_use_stmt = true; 325 return ST_USE; 326 } 327 else 328 undo_new_statement (); 329 } 330 331 if (last_was_use_stmt) 332 use_modules (); 333 334 /* Try matching a data declaration or function declaration. The 335 input "REALFUNCTIONA(N)" can mean several things in different 336 contexts, so it (and its relatives) get special treatment. */ 337 338 if (gfc_current_state () == COMP_NONE 339 || gfc_current_state () == COMP_INTERFACE 340 || gfc_current_state () == COMP_CONTAINS) 341 { 342 gfc_matching_function = true; 343 m = gfc_match_function_decl (); 344 if (m == MATCH_YES) 345 return ST_FUNCTION; 346 else if (m == MATCH_ERROR) 347 reject_statement (); 348 else 349 gfc_undo_symbols (); 350 gfc_current_locus = old_locus; 351 } 352 gfc_matching_function = false; 353 354 /* Legacy parameter statements are ambiguous with assignments so try parameter 355 first. */ 356 match ("parameter", gfc_match_parameter, ST_PARAMETER); 357 358 /* Match statements whose error messages are meant to be overwritten 359 by something better. */ 360 361 match (NULL, gfc_match_assignment, ST_ASSIGNMENT); 362 match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT); 363 364 if (in_specification_block) 365 { 366 m = match_word (NULL, gfc_match_st_function, &old_locus); 367 if (m == MATCH_YES) 368 return ST_STATEMENT_FUNCTION; 369 } 370 371 if (!(in_specification_block && m == MATCH_ERROR)) 372 { 373 match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT); 374 } 375 376 match (NULL, gfc_match_data_decl, ST_DATA_DECL); 377 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); 378 379 /* Try to match a subroutine statement, which has the same optional 380 prefixes that functions can have. */ 381 382 if (gfc_match_subroutine () == MATCH_YES) 383 return ST_SUBROUTINE; 384 gfc_undo_symbols (); 385 gfc_current_locus = old_locus; 386 387 if (gfc_match_submod_proc () == MATCH_YES) 388 { 389 if (gfc_new_block->attr.subroutine) 390 return ST_SUBROUTINE; 391 else if (gfc_new_block->attr.function) 392 return ST_FUNCTION; 393 } 394 gfc_undo_symbols (); 395 gfc_current_locus = old_locus; 396 397 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE 398 statements, which might begin with a block label. The match functions for 399 these statements are unusual in that their keyword is not seen before 400 the matcher is called. */ 401 402 if (gfc_match_if (&st) == MATCH_YES) 403 return st; 404 gfc_undo_symbols (); 405 gfc_current_locus = old_locus; 406 407 if (gfc_match_where (&st) == MATCH_YES) 408 return st; 409 gfc_undo_symbols (); 410 gfc_current_locus = old_locus; 411 412 if (gfc_match_forall (&st) == MATCH_YES) 413 return st; 414 gfc_undo_symbols (); 415 gfc_current_locus = old_locus; 416 417 /* Try to match TYPE as an alias for PRINT. */ 418 if (gfc_match_type (&st) == MATCH_YES) 419 return st; 420 gfc_undo_symbols (); 421 gfc_current_locus = old_locus; 422 423 match (NULL, gfc_match_do, ST_DO); 424 match (NULL, gfc_match_block, ST_BLOCK); 425 match (NULL, gfc_match_associate, ST_ASSOCIATE); 426 match (NULL, gfc_match_critical, ST_CRITICAL); 427 match (NULL, gfc_match_select, ST_SELECT_CASE); 428 match (NULL, gfc_match_select_type, ST_SELECT_TYPE); 429 match (NULL, gfc_match_select_rank, ST_SELECT_RANK); 430 431 /* General statement matching: Instead of testing every possible 432 statement, we eliminate most possibilities by peeking at the 433 first character. */ 434 435 switch (c) 436 { 437 case 'a': 438 match ("abstract% interface", gfc_match_abstract_interface, 439 ST_INTERFACE); 440 match ("allocate", gfc_match_allocate, ST_ALLOCATE); 441 match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); 442 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); 443 match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); 444 match ("automatic", gfc_match_automatic, ST_ATTR_DECL); 445 break; 446 447 case 'b': 448 match ("backspace", gfc_match_backspace, ST_BACKSPACE); 449 match ("block data", gfc_match_block_data, ST_BLOCK_DATA); 450 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); 451 break; 452 453 case 'c': 454 match ("call", gfc_match_call, ST_CALL); 455 match ("change team", gfc_match_change_team, ST_CHANGE_TEAM); 456 match ("close", gfc_match_close, ST_CLOSE); 457 match ("continue", gfc_match_continue, ST_CONTINUE); 458 match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); 459 match ("cycle", gfc_match_cycle, ST_CYCLE); 460 match ("case", gfc_match_case, ST_CASE); 461 match ("common", gfc_match_common, ST_COMMON); 462 match ("contains", gfc_match_eos, ST_CONTAINS); 463 match ("class", gfc_match_class_is, ST_CLASS_IS); 464 match ("codimension", gfc_match_codimension, ST_ATTR_DECL); 465 break; 466 467 case 'd': 468 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE); 469 match ("data", gfc_match_data, ST_DATA); 470 match ("dimension", gfc_match_dimension, ST_ATTR_DECL); 471 break; 472 473 case 'e': 474 match ("end file", gfc_match_endfile, ST_END_FILE); 475 match ("end team", gfc_match_end_team, ST_END_TEAM); 476 match ("exit", gfc_match_exit, ST_EXIT); 477 match ("else", gfc_match_else, ST_ELSE); 478 match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); 479 match ("else if", gfc_match_elseif, ST_ELSEIF); 480 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP); 481 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); 482 483 if (gfc_match_end (&st) == MATCH_YES) 484 return st; 485 486 match ("entry% ", gfc_match_entry, ST_ENTRY); 487 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); 488 match ("external", gfc_match_external, ST_ATTR_DECL); 489 match ("event post", gfc_match_event_post, ST_EVENT_POST); 490 match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT); 491 break; 492 493 case 'f': 494 match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE); 495 match ("final", gfc_match_final_decl, ST_FINAL); 496 match ("flush", gfc_match_flush, ST_FLUSH); 497 match ("form team", gfc_match_form_team, ST_FORM_TEAM); 498 match ("format", gfc_match_format, ST_FORMAT); 499 break; 500 501 case 'g': 502 match ("generic", gfc_match_generic, ST_GENERIC); 503 match ("go to", gfc_match_goto, ST_GOTO); 504 break; 505 506 case 'i': 507 match ("inquire", gfc_match_inquire, ST_INQUIRE); 508 match ("implicit", gfc_match_implicit, ST_IMPLICIT); 509 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); 510 match ("import", gfc_match_import, ST_IMPORT); 511 match ("interface", gfc_match_interface, ST_INTERFACE); 512 match ("intent", gfc_match_intent, ST_ATTR_DECL); 513 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); 514 break; 515 516 case 'l': 517 match ("lock", gfc_match_lock, ST_LOCK); 518 break; 519 520 case 'm': 521 match ("map", gfc_match_map, ST_MAP); 522 match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); 523 match ("module", gfc_match_module, ST_MODULE); 524 break; 525 526 case 'n': 527 match ("nullify", gfc_match_nullify, ST_NULLIFY); 528 match ("namelist", gfc_match_namelist, ST_NAMELIST); 529 break; 530 531 case 'o': 532 match ("open", gfc_match_open, ST_OPEN); 533 match ("optional", gfc_match_optional, ST_ATTR_DECL); 534 break; 535 536 case 'p': 537 match ("print", gfc_match_print, ST_WRITE); 538 match ("pause", gfc_match_pause, ST_PAUSE); 539 match ("pointer", gfc_match_pointer, ST_ATTR_DECL); 540 if (gfc_match_private (&st) == MATCH_YES) 541 return st; 542 match ("procedure", gfc_match_procedure, ST_PROCEDURE); 543 match ("program", gfc_match_program, ST_PROGRAM); 544 if (gfc_match_public (&st) == MATCH_YES) 545 return st; 546 match ("protected", gfc_match_protected, ST_ATTR_DECL); 547 break; 548 549 case 'r': 550 match ("rank", gfc_match_rank_is, ST_RANK); 551 match ("read", gfc_match_read, ST_READ); 552 match ("return", gfc_match_return, ST_RETURN); 553 match ("rewind", gfc_match_rewind, ST_REWIND); 554 break; 555 556 case 's': 557 match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); 558 match ("sequence", gfc_match_eos, ST_SEQUENCE); 559 match ("stop", gfc_match_stop, ST_STOP); 560 match ("save", gfc_match_save, ST_ATTR_DECL); 561 match ("static", gfc_match_static, ST_ATTR_DECL); 562 match ("submodule", gfc_match_submodule, ST_SUBMODULE); 563 match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); 564 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); 565 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); 566 match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM); 567 break; 568 569 case 't': 570 match ("target", gfc_match_target, ST_ATTR_DECL); 571 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); 572 match ("type is", gfc_match_type_is, ST_TYPE_IS); 573 break; 574 575 case 'u': 576 match ("union", gfc_match_union, ST_UNION); 577 match ("unlock", gfc_match_unlock, ST_UNLOCK); 578 break; 579 580 case 'v': 581 match ("value", gfc_match_value, ST_ATTR_DECL); 582 match ("volatile", gfc_match_volatile, ST_ATTR_DECL); 583 break; 584 585 case 'w': 586 match ("wait", gfc_match_wait, ST_WAIT); 587 match ("write", gfc_match_write, ST_WRITE); 588 break; 589 } 590 591 /* All else has failed, so give up. See if any of the matchers has 592 stored an error message of some sort. Suppress the "Unclassifiable 593 statement" if a previous error message was emitted, e.g., by 594 gfc_error_now (). */ 595 if (!gfc_error_check ()) 596 { 597 int ecnt; 598 gfc_get_errors (NULL, &ecnt); 599 if (ecnt <= 0) 600 gfc_error_now ("Unclassifiable statement at %C"); 601 } 602 603 reject_statement (); 604 605 gfc_error_recovery (); 606 607 return ST_NONE; 608 } 609 610 /* Like match and if spec_only, goto do_spec_only without actually 611 matching. */ 612 /* If the directive matched but the clauses failed, do not start 613 matching the next directive in the same switch statement. */ 614 #define matcha(keyword, subr, st) \ 615 do { \ 616 match m2; \ 617 if (spec_only && gfc_match (keyword) == MATCH_YES) \ 618 goto do_spec_only; \ 619 else if ((m2 = match_word (keyword, subr, &old_locus)) \ 620 == MATCH_YES) \ 621 return st; \ 622 else if (m2 == MATCH_ERROR) \ 623 goto error_handling; \ 624 else \ 625 undo_new_statement (); \ 626 } while (0) 627 628 static gfc_statement 629 decode_oacc_directive (void) 630 { 631 locus old_locus; 632 char c; 633 bool spec_only = false; 634 635 gfc_enforce_clean_symbol_state (); 636 637 gfc_clear_error (); /* Clear any pending errors. */ 638 gfc_clear_warning (); /* Clear any pending warnings. */ 639 640 gfc_matching_function = false; 641 642 if (gfc_pure (NULL)) 643 { 644 gfc_error_now ("OpenACC directives at %C may not appear in PURE " 645 "procedures"); 646 gfc_error_recovery (); 647 return ST_NONE; 648 } 649 650 if (gfc_current_state () == COMP_FUNCTION 651 && gfc_current_block ()->result->ts.kind == -1) 652 spec_only = true; 653 654 gfc_unset_implicit_pure (NULL); 655 656 old_locus = gfc_current_locus; 657 658 /* General OpenACC directive matching: Instead of testing every possible 659 statement, we eliminate most possibilities by peeking at the 660 first character. */ 661 662 c = gfc_peek_ascii_char (); 663 664 switch (c) 665 { 666 case 'a': 667 matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); 668 break; 669 case 'c': 670 matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE); 671 break; 672 case 'd': 673 matcha ("data", gfc_match_oacc_data, ST_OACC_DATA); 674 match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE); 675 break; 676 case 'e': 677 matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC); 678 matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA); 679 matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA); 680 matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP); 681 matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS); 682 matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP); 683 matcha ("end parallel loop", gfc_match_omp_eos_error, 684 ST_OACC_END_PARALLEL_LOOP); 685 matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL); 686 matcha ("end serial loop", gfc_match_omp_eos_error, 687 ST_OACC_END_SERIAL_LOOP); 688 matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL); 689 matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA); 690 matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA); 691 break; 692 case 'h': 693 matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA); 694 break; 695 case 'p': 696 matcha ("parallel loop", gfc_match_oacc_parallel_loop, 697 ST_OACC_PARALLEL_LOOP); 698 matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL); 699 break; 700 case 'k': 701 matcha ("kernels loop", gfc_match_oacc_kernels_loop, 702 ST_OACC_KERNELS_LOOP); 703 matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS); 704 break; 705 case 'l': 706 matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP); 707 break; 708 case 'r': 709 match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE); 710 break; 711 case 's': 712 matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP); 713 matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL); 714 break; 715 case 'u': 716 matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE); 717 break; 718 case 'w': 719 matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT); 720 break; 721 } 722 723 /* Directive not found or stored an error message. 724 Check and give up. */ 725 726 error_handling: 727 if (gfc_error_check () == 0) 728 gfc_error_now ("Unclassifiable OpenACC directive at %C"); 729 730 reject_statement (); 731 732 gfc_error_recovery (); 733 734 return ST_NONE; 735 736 do_spec_only: 737 reject_statement (); 738 gfc_clear_error (); 739 gfc_buffer_error (false); 740 gfc_current_locus = old_locus; 741 return ST_GET_FCN_CHARACTERISTICS; 742 } 743 744 /* Like match, but set a flag simd_matched if keyword matched 745 and if spec_only, goto do_spec_only without actually matching. */ 746 #define matchs(keyword, subr, st) \ 747 do { \ 748 match m2; \ 749 if (spec_only && gfc_match (keyword) == MATCH_YES) \ 750 goto do_spec_only; \ 751 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \ 752 &simd_matched)) == MATCH_YES) \ 753 { \ 754 ret = st; \ 755 goto finish; \ 756 } \ 757 else if (m2 == MATCH_ERROR) \ 758 goto error_handling; \ 759 else \ 760 undo_new_statement (); \ 761 } while (0) 762 763 /* Like match, but don't match anything if not -fopenmp 764 and if spec_only, goto do_spec_only without actually matching. */ 765 /* If the directive matched but the clauses failed, do not start 766 matching the next directive in the same switch statement. */ 767 #define matcho(keyword, subr, st) \ 768 do { \ 769 match m2; \ 770 if (!flag_openmp) \ 771 ; \ 772 else if (spec_only && gfc_match (keyword) == MATCH_YES) \ 773 goto do_spec_only; \ 774 else if ((m2 = match_word (keyword, subr, &old_locus)) \ 775 == MATCH_YES) \ 776 { \ 777 ret = st; \ 778 goto finish; \ 779 } \ 780 else if (m2 == MATCH_ERROR) \ 781 goto error_handling; \ 782 else \ 783 undo_new_statement (); \ 784 } while (0) 785 786 /* Like match, but set a flag simd_matched if keyword matched. */ 787 #define matchds(keyword, subr, st) \ 788 do { \ 789 match m2; \ 790 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \ 791 &simd_matched)) == MATCH_YES) \ 792 { \ 793 ret = st; \ 794 goto finish; \ 795 } \ 796 else if (m2 == MATCH_ERROR) \ 797 goto error_handling; \ 798 else \ 799 undo_new_statement (); \ 800 } while (0) 801 802 /* Like match, but don't match anything if not -fopenmp. */ 803 #define matchdo(keyword, subr, st) \ 804 do { \ 805 match m2; \ 806 if (!flag_openmp) \ 807 ; \ 808 else if ((m2 = match_word (keyword, subr, &old_locus)) \ 809 == MATCH_YES) \ 810 { \ 811 ret = st; \ 812 goto finish; \ 813 } \ 814 else if (m2 == MATCH_ERROR) \ 815 goto error_handling; \ 816 else \ 817 undo_new_statement (); \ 818 } while (0) 819 820 static gfc_statement 821 decode_omp_directive (void) 822 { 823 locus old_locus; 824 char c; 825 bool simd_matched = false; 826 bool spec_only = false; 827 gfc_statement ret = ST_NONE; 828 bool pure_ok = true; 829 830 gfc_enforce_clean_symbol_state (); 831 832 gfc_clear_error (); /* Clear any pending errors. */ 833 gfc_clear_warning (); /* Clear any pending warnings. */ 834 835 gfc_matching_function = false; 836 837 if (gfc_current_state () == COMP_FUNCTION 838 && gfc_current_block ()->result->ts.kind == -1) 839 spec_only = true; 840 841 old_locus = gfc_current_locus; 842 843 /* General OpenMP directive matching: Instead of testing every possible 844 statement, we eliminate most possibilities by peeking at the 845 first character. */ 846 847 c = gfc_peek_ascii_char (); 848 849 /* match is for directives that should be recognized only if 850 -fopenmp, matchs for directives that should be recognized 851 if either -fopenmp or -fopenmp-simd. 852 Handle only the directives allowed in PURE/ELEMENTAL procedures 853 first (those also shall not turn off implicit pure). */ 854 switch (c) 855 { 856 case 'd': 857 matchds ("declare simd", gfc_match_omp_declare_simd, 858 ST_OMP_DECLARE_SIMD); 859 matchdo ("declare target", gfc_match_omp_declare_target, 860 ST_OMP_DECLARE_TARGET); 861 break; 862 case 's': 863 matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD); 864 break; 865 } 866 867 pure_ok = false; 868 if (flag_openmp && gfc_pure (NULL)) 869 { 870 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " 871 "at %C may not appear in PURE or ELEMENTAL procedures"); 872 gfc_error_recovery (); 873 return ST_NONE; 874 } 875 876 /* match is for directives that should be recognized only if 877 -fopenmp, matchs for directives that should be recognized 878 if either -fopenmp or -fopenmp-simd. */ 879 switch (c) 880 { 881 case 'a': 882 matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); 883 break; 884 case 'b': 885 matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); 886 break; 887 case 'c': 888 matcho ("cancellation% point", gfc_match_omp_cancellation_point, 889 ST_OMP_CANCELLATION_POINT); 890 matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL); 891 matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); 892 break; 893 case 'd': 894 matchds ("declare reduction", gfc_match_omp_declare_reduction, 895 ST_OMP_DECLARE_REDUCTION); 896 matchs ("distribute parallel do simd", 897 gfc_match_omp_distribute_parallel_do_simd, 898 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD); 899 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do, 900 ST_OMP_DISTRIBUTE_PARALLEL_DO); 901 matchs ("distribute simd", gfc_match_omp_distribute_simd, 902 ST_OMP_DISTRIBUTE_SIMD); 903 matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE); 904 matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD); 905 matcho ("do", gfc_match_omp_do, ST_OMP_DO); 906 break; 907 case 'e': 908 matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC); 909 matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL); 910 matchs ("end distribute parallel do simd", gfc_match_omp_eos_error, 911 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD); 912 matcho ("end distribute parallel do", gfc_match_omp_eos_error, 913 ST_OMP_END_DISTRIBUTE_PARALLEL_DO); 914 matchs ("end distribute simd", gfc_match_omp_eos_error, 915 ST_OMP_END_DISTRIBUTE_SIMD); 916 matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE); 917 matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD); 918 matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); 919 matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD); 920 matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER); 921 matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED); 922 matchs ("end parallel do simd", gfc_match_omp_eos_error, 923 ST_OMP_END_PARALLEL_DO_SIMD); 924 matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO); 925 matcho ("end parallel sections", gfc_match_omp_eos_error, 926 ST_OMP_END_PARALLEL_SECTIONS); 927 matcho ("end parallel workshare", gfc_match_omp_eos_error, 928 ST_OMP_END_PARALLEL_WORKSHARE); 929 matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL); 930 matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); 931 matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); 932 matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA); 933 matchs ("end target parallel do simd", gfc_match_omp_eos_error, 934 ST_OMP_END_TARGET_PARALLEL_DO_SIMD); 935 matcho ("end target parallel do", gfc_match_omp_eos_error, 936 ST_OMP_END_TARGET_PARALLEL_DO); 937 matcho ("end target parallel", gfc_match_omp_eos_error, 938 ST_OMP_END_TARGET_PARALLEL); 939 matchs ("end target simd", gfc_match_omp_eos_error, ST_OMP_END_TARGET_SIMD); 940 matchs ("end target teams distribute parallel do simd", 941 gfc_match_omp_eos_error, 942 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); 943 matcho ("end target teams distribute parallel do", gfc_match_omp_eos_error, 944 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); 945 matchs ("end target teams distribute simd", gfc_match_omp_eos_error, 946 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD); 947 matcho ("end target teams distribute", gfc_match_omp_eos_error, 948 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE); 949 matcho ("end target teams", gfc_match_omp_eos_error, ST_OMP_END_TARGET_TEAMS); 950 matcho ("end target", gfc_match_omp_eos_error, ST_OMP_END_TARGET); 951 matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP); 952 matchs ("end taskloop simd", gfc_match_omp_eos_error, 953 ST_OMP_END_TASKLOOP_SIMD); 954 matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP); 955 matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK); 956 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error, 957 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); 958 matcho ("end teams distribute parallel do", gfc_match_omp_eos_error, 959 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO); 960 matchs ("end teams distribute simd", gfc_match_omp_eos_error, 961 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD); 962 matcho ("end teams distribute", gfc_match_omp_eos_error, 963 ST_OMP_END_TEAMS_DISTRIBUTE); 964 matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS); 965 matcho ("end workshare", gfc_match_omp_end_nowait, 966 ST_OMP_END_WORKSHARE); 967 break; 968 case 'f': 969 matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); 970 break; 971 case 'm': 972 matcho ("master", gfc_match_omp_master, ST_OMP_MASTER); 973 break; 974 case 'o': 975 if (gfc_match ("ordered depend (") == MATCH_YES) 976 { 977 gfc_current_locus = old_locus; 978 if (!flag_openmp) 979 break; 980 matcho ("ordered", gfc_match_omp_ordered_depend, 981 ST_OMP_ORDERED_DEPEND); 982 } 983 else 984 matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED); 985 break; 986 case 'p': 987 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd, 988 ST_OMP_PARALLEL_DO_SIMD); 989 matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); 990 matcho ("parallel sections", gfc_match_omp_parallel_sections, 991 ST_OMP_PARALLEL_SECTIONS); 992 matcho ("parallel workshare", gfc_match_omp_parallel_workshare, 993 ST_OMP_PARALLEL_WORKSHARE); 994 matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); 995 break; 996 case 's': 997 matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); 998 matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION); 999 matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE); 1000 break; 1001 case 't': 1002 matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA); 1003 matcho ("target enter data", gfc_match_omp_target_enter_data, 1004 ST_OMP_TARGET_ENTER_DATA); 1005 matcho ("target exit data", gfc_match_omp_target_exit_data, 1006 ST_OMP_TARGET_EXIT_DATA); 1007 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd, 1008 ST_OMP_TARGET_PARALLEL_DO_SIMD); 1009 matcho ("target parallel do", gfc_match_omp_target_parallel_do, 1010 ST_OMP_TARGET_PARALLEL_DO); 1011 matcho ("target parallel", gfc_match_omp_target_parallel, 1012 ST_OMP_TARGET_PARALLEL); 1013 matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD); 1014 matchs ("target teams distribute parallel do simd", 1015 gfc_match_omp_target_teams_distribute_parallel_do_simd, 1016 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); 1017 matcho ("target teams distribute parallel do", 1018 gfc_match_omp_target_teams_distribute_parallel_do, 1019 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); 1020 matchs ("target teams distribute simd", 1021 gfc_match_omp_target_teams_distribute_simd, 1022 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD); 1023 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute, 1024 ST_OMP_TARGET_TEAMS_DISTRIBUTE); 1025 matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS); 1026 matcho ("target update", gfc_match_omp_target_update, 1027 ST_OMP_TARGET_UPDATE); 1028 matcho ("target", gfc_match_omp_target, ST_OMP_TARGET); 1029 matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP); 1030 matchs ("taskloop simd", gfc_match_omp_taskloop_simd, 1031 ST_OMP_TASKLOOP_SIMD); 1032 matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP); 1033 matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT); 1034 matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD); 1035 matcho ("task", gfc_match_omp_task, ST_OMP_TASK); 1036 matchs ("teams distribute parallel do simd", 1037 gfc_match_omp_teams_distribute_parallel_do_simd, 1038 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); 1039 matcho ("teams distribute parallel do", 1040 gfc_match_omp_teams_distribute_parallel_do, 1041 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO); 1042 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd, 1043 ST_OMP_TEAMS_DISTRIBUTE_SIMD); 1044 matcho ("teams distribute", gfc_match_omp_teams_distribute, 1045 ST_OMP_TEAMS_DISTRIBUTE); 1046 matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS); 1047 matchdo ("threadprivate", gfc_match_omp_threadprivate, 1048 ST_OMP_THREADPRIVATE); 1049 break; 1050 case 'w': 1051 matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); 1052 break; 1053 } 1054 1055 /* All else has failed, so give up. See if any of the matchers has 1056 stored an error message of some sort. Don't error out if 1057 not -fopenmp and simd_matched is false, i.e. if a directive other 1058 than one marked with match has been seen. */ 1059 1060 error_handling: 1061 if (flag_openmp || simd_matched) 1062 { 1063 if (!gfc_error_check ()) 1064 gfc_error_now ("Unclassifiable OpenMP directive at %C"); 1065 } 1066 1067 reject_statement (); 1068 1069 gfc_error_recovery (); 1070 1071 return ST_NONE; 1072 1073 finish: 1074 if (!pure_ok) 1075 { 1076 gfc_unset_implicit_pure (NULL); 1077 1078 if (!flag_openmp && gfc_pure (NULL)) 1079 { 1080 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " 1081 "at %C may not appear in PURE or ELEMENTAL " 1082 "procedures"); 1083 reject_statement (); 1084 gfc_error_recovery (); 1085 return ST_NONE; 1086 } 1087 } 1088 return ret; 1089 1090 do_spec_only: 1091 reject_statement (); 1092 gfc_clear_error (); 1093 gfc_buffer_error (false); 1094 gfc_current_locus = old_locus; 1095 return ST_GET_FCN_CHARACTERISTICS; 1096 } 1097 1098 static gfc_statement 1099 decode_gcc_attribute (void) 1100 { 1101 locus old_locus; 1102 1103 gfc_enforce_clean_symbol_state (); 1104 1105 gfc_clear_error (); /* Clear any pending errors. */ 1106 gfc_clear_warning (); /* Clear any pending warnings. */ 1107 old_locus = gfc_current_locus; 1108 1109 match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL); 1110 match ("unroll", gfc_match_gcc_unroll, ST_NONE); 1111 match ("builtin", gfc_match_gcc_builtin, ST_NONE); 1112 match ("ivdep", gfc_match_gcc_ivdep, ST_NONE); 1113 match ("vector", gfc_match_gcc_vector, ST_NONE); 1114 match ("novector", gfc_match_gcc_novector, ST_NONE); 1115 1116 /* All else has failed, so give up. See if any of the matchers has 1117 stored an error message of some sort. */ 1118 1119 if (!gfc_error_check ()) 1120 { 1121 if (pedantic) 1122 gfc_error_now ("Unclassifiable GCC directive at %C"); 1123 else 1124 gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored"); 1125 } 1126 1127 reject_statement (); 1128 1129 gfc_error_recovery (); 1130 1131 return ST_NONE; 1132 } 1133 1134 #undef match 1135 1136 /* Assert next length characters to be equal to token in free form. */ 1137 1138 static void 1139 verify_token_free (const char* token, int length, bool last_was_use_stmt) 1140 { 1141 int i; 1142 char c; 1143 1144 c = gfc_next_ascii_char (); 1145 for (i = 0; i < length; i++, c = gfc_next_ascii_char ()) 1146 gcc_assert (c == token[i]); 1147 1148 gcc_assert (gfc_is_whitespace(c)); 1149 gfc_gobble_whitespace (); 1150 if (last_was_use_stmt) 1151 use_modules (); 1152 } 1153 1154 /* Get the next statement in free form source. */ 1155 1156 static gfc_statement 1157 next_free (void) 1158 { 1159 match m; 1160 int i, cnt, at_bol; 1161 char c; 1162 1163 at_bol = gfc_at_bol (); 1164 gfc_gobble_whitespace (); 1165 1166 c = gfc_peek_ascii_char (); 1167 1168 if (ISDIGIT (c)) 1169 { 1170 char d; 1171 1172 /* Found a statement label? */ 1173 m = gfc_match_st_label (&gfc_statement_label); 1174 1175 d = gfc_peek_ascii_char (); 1176 if (m != MATCH_YES || !gfc_is_whitespace (d)) 1177 { 1178 gfc_match_small_literal_int (&i, &cnt); 1179 1180 if (cnt > 5) 1181 gfc_error_now ("Too many digits in statement label at %C"); 1182 1183 if (i == 0) 1184 gfc_error_now ("Zero is not a valid statement label at %C"); 1185 1186 do 1187 c = gfc_next_ascii_char (); 1188 while (ISDIGIT(c)); 1189 1190 if (!gfc_is_whitespace (c)) 1191 gfc_error_now ("Non-numeric character in statement label at %C"); 1192 1193 return ST_NONE; 1194 } 1195 else 1196 { 1197 label_locus = gfc_current_locus; 1198 1199 gfc_gobble_whitespace (); 1200 1201 if (at_bol && gfc_peek_ascii_char () == ';') 1202 { 1203 gfc_error_now ("Semicolon at %C needs to be preceded by " 1204 "statement"); 1205 gfc_next_ascii_char (); /* Eat up the semicolon. */ 1206 return ST_NONE; 1207 } 1208 1209 if (gfc_match_eos () == MATCH_YES) 1210 gfc_error_now ("Statement label without statement at %L", 1211 &label_locus); 1212 } 1213 } 1214 else if (c == '!') 1215 { 1216 /* Comments have already been skipped by the time we get here, 1217 except for GCC attributes and OpenMP/OpenACC directives. */ 1218 1219 gfc_next_ascii_char (); /* Eat up the exclamation sign. */ 1220 c = gfc_peek_ascii_char (); 1221 1222 if (c == 'g') 1223 { 1224 int i; 1225 1226 c = gfc_next_ascii_char (); 1227 for (i = 0; i < 4; i++, c = gfc_next_ascii_char ()) 1228 gcc_assert (c == "gcc$"[i]); 1229 1230 gfc_gobble_whitespace (); 1231 return decode_gcc_attribute (); 1232 1233 } 1234 else if (c == '$') 1235 { 1236 /* Since both OpenMP and OpenACC directives starts with 1237 !$ character sequence, we must check all flags combinations */ 1238 if ((flag_openmp || flag_openmp_simd) 1239 && !flag_openacc) 1240 { 1241 verify_token_free ("$omp", 4, last_was_use_stmt); 1242 return decode_omp_directive (); 1243 } 1244 else if ((flag_openmp || flag_openmp_simd) 1245 && flag_openacc) 1246 { 1247 gfc_next_ascii_char (); /* Eat up dollar character */ 1248 c = gfc_peek_ascii_char (); 1249 1250 if (c == 'o') 1251 { 1252 verify_token_free ("omp", 3, last_was_use_stmt); 1253 return decode_omp_directive (); 1254 } 1255 else if (c == 'a') 1256 { 1257 verify_token_free ("acc", 3, last_was_use_stmt); 1258 return decode_oacc_directive (); 1259 } 1260 } 1261 else if (flag_openacc) 1262 { 1263 verify_token_free ("$acc", 4, last_was_use_stmt); 1264 return decode_oacc_directive (); 1265 } 1266 } 1267 gcc_unreachable (); 1268 } 1269 1270 if (at_bol && c == ';') 1271 { 1272 if (!(gfc_option.allow_std & GFC_STD_F2008)) 1273 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " 1274 "statement"); 1275 gfc_next_ascii_char (); /* Eat up the semicolon. */ 1276 return ST_NONE; 1277 } 1278 1279 return decode_statement (); 1280 } 1281 1282 /* Assert next length characters to be equal to token in fixed form. */ 1283 1284 static bool 1285 verify_token_fixed (const char *token, int length, bool last_was_use_stmt) 1286 { 1287 int i; 1288 char c = gfc_next_char_literal (NONSTRING); 1289 1290 for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING)) 1291 gcc_assert ((char) gfc_wide_tolower (c) == token[i]); 1292 1293 if (c != ' ' && c != '0') 1294 { 1295 gfc_buffer_error (false); 1296 gfc_error ("Bad continuation line at %C"); 1297 return false; 1298 } 1299 if (last_was_use_stmt) 1300 use_modules (); 1301 1302 return true; 1303 } 1304 1305 /* Get the next statement in fixed-form source. */ 1306 1307 static gfc_statement 1308 next_fixed (void) 1309 { 1310 int label, digit_flag, i; 1311 locus loc; 1312 gfc_char_t c; 1313 1314 if (!gfc_at_bol ()) 1315 return decode_statement (); 1316 1317 /* Skip past the current label field, parsing a statement label if 1318 one is there. This is a weird number parser, since the number is 1319 contained within five columns and can have any kind of embedded 1320 spaces. We also check for characters that make the rest of the 1321 line a comment. */ 1322 1323 label = 0; 1324 digit_flag = 0; 1325 1326 for (i = 0; i < 5; i++) 1327 { 1328 c = gfc_next_char_literal (NONSTRING); 1329 1330 switch (c) 1331 { 1332 case ' ': 1333 break; 1334 1335 case '0': 1336 case '1': 1337 case '2': 1338 case '3': 1339 case '4': 1340 case '5': 1341 case '6': 1342 case '7': 1343 case '8': 1344 case '9': 1345 label = label * 10 + ((unsigned char) c - '0'); 1346 label_locus = gfc_current_locus; 1347 digit_flag = 1; 1348 break; 1349 1350 /* Comments have already been skipped by the time we get 1351 here, except for GCC attributes and OpenMP directives. */ 1352 1353 case '*': 1354 c = gfc_next_char_literal (NONSTRING); 1355 1356 if (TOLOWER (c) == 'g') 1357 { 1358 for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING)) 1359 gcc_assert (TOLOWER (c) == "gcc$"[i]); 1360 1361 return decode_gcc_attribute (); 1362 } 1363 else if (c == '$') 1364 { 1365 if ((flag_openmp || flag_openmp_simd) 1366 && !flag_openacc) 1367 { 1368 if (!verify_token_fixed ("omp", 3, last_was_use_stmt)) 1369 return ST_NONE; 1370 return decode_omp_directive (); 1371 } 1372 else if ((flag_openmp || flag_openmp_simd) 1373 && flag_openacc) 1374 { 1375 c = gfc_next_char_literal(NONSTRING); 1376 if (c == 'o' || c == 'O') 1377 { 1378 if (!verify_token_fixed ("mp", 2, last_was_use_stmt)) 1379 return ST_NONE; 1380 return decode_omp_directive (); 1381 } 1382 else if (c == 'a' || c == 'A') 1383 { 1384 if (!verify_token_fixed ("cc", 2, last_was_use_stmt)) 1385 return ST_NONE; 1386 return decode_oacc_directive (); 1387 } 1388 } 1389 else if (flag_openacc) 1390 { 1391 if (!verify_token_fixed ("acc", 3, last_was_use_stmt)) 1392 return ST_NONE; 1393 return decode_oacc_directive (); 1394 } 1395 } 1396 gcc_fallthrough (); 1397 1398 /* Comments have already been skipped by the time we get 1399 here so don't bother checking for them. */ 1400 1401 default: 1402 gfc_buffer_error (false); 1403 gfc_error ("Non-numeric character in statement label at %C"); 1404 return ST_NONE; 1405 } 1406 } 1407 1408 if (digit_flag) 1409 { 1410 if (label == 0) 1411 gfc_warning_now (0, "Zero is not a valid statement label at %C"); 1412 else 1413 { 1414 /* We've found a valid statement label. */ 1415 gfc_statement_label = gfc_get_st_label (label); 1416 } 1417 } 1418 1419 /* Since this line starts a statement, it cannot be a continuation 1420 of a previous statement. If we see something here besides a 1421 space or zero, it must be a bad continuation line. */ 1422 1423 c = gfc_next_char_literal (NONSTRING); 1424 if (c == '\n') 1425 goto blank_line; 1426 1427 if (c != ' ' && c != '0') 1428 { 1429 gfc_buffer_error (false); 1430 gfc_error ("Bad continuation line at %C"); 1431 return ST_NONE; 1432 } 1433 1434 /* Now that we've taken care of the statement label columns, we have 1435 to make sure that the first nonblank character is not a '!'. If 1436 it is, the rest of the line is a comment. */ 1437 1438 do 1439 { 1440 loc = gfc_current_locus; 1441 c = gfc_next_char_literal (NONSTRING); 1442 } 1443 while (gfc_is_whitespace (c)); 1444 1445 if (c == '!') 1446 goto blank_line; 1447 gfc_current_locus = loc; 1448 1449 if (c == ';') 1450 { 1451 if (digit_flag) 1452 gfc_error_now ("Semicolon at %C needs to be preceded by statement"); 1453 else if (!(gfc_option.allow_std & GFC_STD_F2008)) 1454 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " 1455 "statement"); 1456 return ST_NONE; 1457 } 1458 1459 if (gfc_match_eos () == MATCH_YES) 1460 goto blank_line; 1461 1462 /* At this point, we've got a nonblank statement to parse. */ 1463 return decode_statement (); 1464 1465 blank_line: 1466 if (digit_flag) 1467 gfc_error_now ("Statement label without statement at %L", &label_locus); 1468 1469 gfc_current_locus.lb->truncated = 0; 1470 gfc_advance_line (); 1471 return ST_NONE; 1472 } 1473 1474 1475 /* Return the next non-ST_NONE statement to the caller. We also worry 1476 about including files and the ends of include files at this stage. */ 1477 1478 static gfc_statement 1479 next_statement (void) 1480 { 1481 gfc_statement st; 1482 locus old_locus; 1483 1484 gfc_enforce_clean_symbol_state (); 1485 1486 gfc_new_block = NULL; 1487 1488 gfc_current_ns->old_equiv = gfc_current_ns->equiv; 1489 gfc_current_ns->old_data = gfc_current_ns->data; 1490 for (;;) 1491 { 1492 gfc_statement_label = NULL; 1493 gfc_buffer_error (true); 1494 1495 if (gfc_at_eol ()) 1496 gfc_advance_line (); 1497 1498 gfc_skip_comments (); 1499 1500 if (gfc_at_end ()) 1501 { 1502 st = ST_NONE; 1503 break; 1504 } 1505 1506 if (gfc_define_undef_line ()) 1507 continue; 1508 1509 old_locus = gfc_current_locus; 1510 1511 st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free (); 1512 1513 if (st != ST_NONE) 1514 break; 1515 } 1516 1517 gfc_buffer_error (false); 1518 1519 if (st == ST_GET_FCN_CHARACTERISTICS) 1520 { 1521 if (gfc_statement_label != NULL) 1522 { 1523 gfc_free_st_label (gfc_statement_label); 1524 gfc_statement_label = NULL; 1525 } 1526 gfc_current_locus = old_locus; 1527 } 1528 1529 if (st != ST_NONE) 1530 check_statement_label (st); 1531 1532 return st; 1533 } 1534 1535 1536 /****************************** Parser ***********************************/ 1537 1538 /* The parser subroutines are of type 'try' that fail if the file ends 1539 unexpectedly. */ 1540 1541 /* Macros that expand to case-labels for various classes of 1542 statements. Start with executable statements that directly do 1543 things. */ 1544 1545 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \ 1546 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ 1547 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ 1548 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ 1549 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \ 1550 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ 1551 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ 1552 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ 1553 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \ 1554 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \ 1555 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \ 1556 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \ 1557 case ST_ERROR_STOP: case ST_SYNC_ALL: \ 1558 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ 1559 case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ 1560 case ST_END_TEAM: case ST_SYNC_TEAM: \ 1561 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ 1562 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ 1563 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA 1564 1565 /* Statements that mark other executable statements. */ 1566 1567 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ 1568 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ 1569 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ 1570 case ST_SELECT_RANK: case ST_OMP_PARALLEL: \ 1571 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ 1572 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ 1573 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ 1574 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \ 1575 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \ 1576 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \ 1577 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \ 1578 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \ 1579 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \ 1580 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \ 1581 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ 1582 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \ 1583 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \ 1584 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \ 1585 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \ 1586 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \ 1587 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \ 1588 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \ 1589 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ 1590 case ST_CRITICAL: \ 1591 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \ 1592 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ 1593 case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \ 1594 case ST_OACC_ATOMIC 1595 1596 /* Declaration statements */ 1597 1598 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ 1599 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ 1600 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \ 1601 case ST_OACC_DECLARE 1602 1603 /* OpenMP declaration statements. */ 1604 1605 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ 1606 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION 1607 1608 /* Block end statements. Errors associated with interchanging these 1609 are detected in gfc_match_end(). */ 1610 1611 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ 1612 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ 1613 case ST_END_BLOCK: case ST_END_ASSOCIATE 1614 1615 1616 /* Push a new state onto the stack. */ 1617 1618 static void 1619 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym) 1620 { 1621 p->state = new_state; 1622 p->previous = gfc_state_stack; 1623 p->sym = sym; 1624 p->head = p->tail = NULL; 1625 p->do_variable = NULL; 1626 if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT) 1627 p->ext.oacc_declare_clauses = NULL; 1628 1629 /* If this the state of a construct like BLOCK, DO or IF, the corresponding 1630 construct statement was accepted right before pushing the state. Thus, 1631 the construct's gfc_code is available as tail of the parent state. */ 1632 gcc_assert (gfc_state_stack); 1633 p->construct = gfc_state_stack->tail; 1634 1635 gfc_state_stack = p; 1636 } 1637 1638 1639 /* Pop the current state. */ 1640 static void 1641 pop_state (void) 1642 { 1643 gfc_state_stack = gfc_state_stack->previous; 1644 } 1645 1646 1647 /* Try to find the given state in the state stack. */ 1648 1649 bool 1650 gfc_find_state (gfc_compile_state state) 1651 { 1652 gfc_state_data *p; 1653 1654 for (p = gfc_state_stack; p; p = p->previous) 1655 if (p->state == state) 1656 break; 1657 1658 return (p == NULL) ? false : true; 1659 } 1660 1661 1662 /* Starts a new level in the statement list. */ 1663 1664 static gfc_code * 1665 new_level (gfc_code *q) 1666 { 1667 gfc_code *p; 1668 1669 p = q->block = gfc_get_code (EXEC_NOP); 1670 1671 gfc_state_stack->head = gfc_state_stack->tail = p; 1672 1673 return p; 1674 } 1675 1676 1677 /* Add the current new_st code structure and adds it to the current 1678 program unit. As a side-effect, it zeroes the new_st. */ 1679 1680 static gfc_code * 1681 add_statement (void) 1682 { 1683 gfc_code *p; 1684 1685 p = XCNEW (gfc_code); 1686 *p = new_st; 1687 1688 p->loc = gfc_current_locus; 1689 1690 if (gfc_state_stack->head == NULL) 1691 gfc_state_stack->head = p; 1692 else 1693 gfc_state_stack->tail->next = p; 1694 1695 while (p->next != NULL) 1696 p = p->next; 1697 1698 gfc_state_stack->tail = p; 1699 1700 gfc_clear_new_st (); 1701 1702 return p; 1703 } 1704 1705 1706 /* Frees everything associated with the current statement. */ 1707 1708 static void 1709 undo_new_statement (void) 1710 { 1711 gfc_free_statements (new_st.block); 1712 gfc_free_statements (new_st.next); 1713 gfc_free_statement (&new_st); 1714 gfc_clear_new_st (); 1715 } 1716 1717 1718 /* If the current statement has a statement label, make sure that it 1719 is allowed to, or should have one. */ 1720 1721 static void 1722 check_statement_label (gfc_statement st) 1723 { 1724 gfc_sl_type type; 1725 1726 if (gfc_statement_label == NULL) 1727 { 1728 if (st == ST_FORMAT) 1729 gfc_error ("FORMAT statement at %L does not have a statement label", 1730 &new_st.loc); 1731 return; 1732 } 1733 1734 switch (st) 1735 { 1736 case ST_END_PROGRAM: 1737 case ST_END_FUNCTION: 1738 case ST_END_SUBROUTINE: 1739 case ST_ENDDO: 1740 case ST_ENDIF: 1741 case ST_END_SELECT: 1742 case ST_END_CRITICAL: 1743 case ST_END_BLOCK: 1744 case ST_END_ASSOCIATE: 1745 case_executable: 1746 case_exec_markers: 1747 if (st == ST_ENDDO || st == ST_CONTINUE) 1748 type = ST_LABEL_DO_TARGET; 1749 else 1750 type = ST_LABEL_TARGET; 1751 break; 1752 1753 case ST_FORMAT: 1754 type = ST_LABEL_FORMAT; 1755 break; 1756 1757 /* Statement labels are not restricted from appearing on a 1758 particular line. However, there are plenty of situations 1759 where the resulting label can't be referenced. */ 1760 1761 default: 1762 type = ST_LABEL_BAD_TARGET; 1763 break; 1764 } 1765 1766 gfc_define_st_label (gfc_statement_label, type, &label_locus); 1767 1768 new_st.here = gfc_statement_label; 1769 } 1770 1771 1772 /* Figures out what the enclosing program unit is. This will be a 1773 function, subroutine, program, block data or module. */ 1774 1775 gfc_state_data * 1776 gfc_enclosing_unit (gfc_compile_state * result) 1777 { 1778 gfc_state_data *p; 1779 1780 for (p = gfc_state_stack; p; p = p->previous) 1781 if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE 1782 || p->state == COMP_MODULE || p->state == COMP_SUBMODULE 1783 || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM) 1784 { 1785 1786 if (result != NULL) 1787 *result = p->state; 1788 return p; 1789 } 1790 1791 if (result != NULL) 1792 *result = COMP_PROGRAM; 1793 return NULL; 1794 } 1795 1796 1797 /* Translate a statement enum to a string. */ 1798 1799 const char * 1800 gfc_ascii_statement (gfc_statement st) 1801 { 1802 const char *p; 1803 1804 switch (st) 1805 { 1806 case ST_ARITHMETIC_IF: 1807 p = _("arithmetic IF"); 1808 break; 1809 case ST_ALLOCATE: 1810 p = "ALLOCATE"; 1811 break; 1812 case ST_ASSOCIATE: 1813 p = "ASSOCIATE"; 1814 break; 1815 case ST_ATTR_DECL: 1816 p = _("attribute declaration"); 1817 break; 1818 case ST_BACKSPACE: 1819 p = "BACKSPACE"; 1820 break; 1821 case ST_BLOCK: 1822 p = "BLOCK"; 1823 break; 1824 case ST_BLOCK_DATA: 1825 p = "BLOCK DATA"; 1826 break; 1827 case ST_CALL: 1828 p = "CALL"; 1829 break; 1830 case ST_CASE: 1831 p = "CASE"; 1832 break; 1833 case ST_CLOSE: 1834 p = "CLOSE"; 1835 break; 1836 case ST_COMMON: 1837 p = "COMMON"; 1838 break; 1839 case ST_CONTINUE: 1840 p = "CONTINUE"; 1841 break; 1842 case ST_CONTAINS: 1843 p = "CONTAINS"; 1844 break; 1845 case ST_CRITICAL: 1846 p = "CRITICAL"; 1847 break; 1848 case ST_CYCLE: 1849 p = "CYCLE"; 1850 break; 1851 case ST_DATA_DECL: 1852 p = _("data declaration"); 1853 break; 1854 case ST_DATA: 1855 p = "DATA"; 1856 break; 1857 case ST_DEALLOCATE: 1858 p = "DEALLOCATE"; 1859 break; 1860 case ST_MAP: 1861 p = "MAP"; 1862 break; 1863 case ST_UNION: 1864 p = "UNION"; 1865 break; 1866 case ST_STRUCTURE_DECL: 1867 p = "STRUCTURE"; 1868 break; 1869 case ST_DERIVED_DECL: 1870 p = _("derived type declaration"); 1871 break; 1872 case ST_DO: 1873 p = "DO"; 1874 break; 1875 case ST_ELSE: 1876 p = "ELSE"; 1877 break; 1878 case ST_ELSEIF: 1879 p = "ELSE IF"; 1880 break; 1881 case ST_ELSEWHERE: 1882 p = "ELSEWHERE"; 1883 break; 1884 case ST_EVENT_POST: 1885 p = "EVENT POST"; 1886 break; 1887 case ST_EVENT_WAIT: 1888 p = "EVENT WAIT"; 1889 break; 1890 case ST_FAIL_IMAGE: 1891 p = "FAIL IMAGE"; 1892 break; 1893 case ST_CHANGE_TEAM: 1894 p = "CHANGE TEAM"; 1895 break; 1896 case ST_END_TEAM: 1897 p = "END TEAM"; 1898 break; 1899 case ST_FORM_TEAM: 1900 p = "FORM TEAM"; 1901 break; 1902 case ST_SYNC_TEAM: 1903 p = "SYNC TEAM"; 1904 break; 1905 case ST_END_ASSOCIATE: 1906 p = "END ASSOCIATE"; 1907 break; 1908 case ST_END_BLOCK: 1909 p = "END BLOCK"; 1910 break; 1911 case ST_END_BLOCK_DATA: 1912 p = "END BLOCK DATA"; 1913 break; 1914 case ST_END_CRITICAL: 1915 p = "END CRITICAL"; 1916 break; 1917 case ST_ENDDO: 1918 p = "END DO"; 1919 break; 1920 case ST_END_FILE: 1921 p = "END FILE"; 1922 break; 1923 case ST_END_FORALL: 1924 p = "END FORALL"; 1925 break; 1926 case ST_END_FUNCTION: 1927 p = "END FUNCTION"; 1928 break; 1929 case ST_ENDIF: 1930 p = "END IF"; 1931 break; 1932 case ST_END_INTERFACE: 1933 p = "END INTERFACE"; 1934 break; 1935 case ST_END_MODULE: 1936 p = "END MODULE"; 1937 break; 1938 case ST_END_SUBMODULE: 1939 p = "END SUBMODULE"; 1940 break; 1941 case ST_END_PROGRAM: 1942 p = "END PROGRAM"; 1943 break; 1944 case ST_END_SELECT: 1945 p = "END SELECT"; 1946 break; 1947 case ST_END_SUBROUTINE: 1948 p = "END SUBROUTINE"; 1949 break; 1950 case ST_END_WHERE: 1951 p = "END WHERE"; 1952 break; 1953 case ST_END_STRUCTURE: 1954 p = "END STRUCTURE"; 1955 break; 1956 case ST_END_UNION: 1957 p = "END UNION"; 1958 break; 1959 case ST_END_MAP: 1960 p = "END MAP"; 1961 break; 1962 case ST_END_TYPE: 1963 p = "END TYPE"; 1964 break; 1965 case ST_ENTRY: 1966 p = "ENTRY"; 1967 break; 1968 case ST_EQUIVALENCE: 1969 p = "EQUIVALENCE"; 1970 break; 1971 case ST_ERROR_STOP: 1972 p = "ERROR STOP"; 1973 break; 1974 case ST_EXIT: 1975 p = "EXIT"; 1976 break; 1977 case ST_FLUSH: 1978 p = "FLUSH"; 1979 break; 1980 case ST_FORALL_BLOCK: /* Fall through */ 1981 case ST_FORALL: 1982 p = "FORALL"; 1983 break; 1984 case ST_FORMAT: 1985 p = "FORMAT"; 1986 break; 1987 case ST_FUNCTION: 1988 p = "FUNCTION"; 1989 break; 1990 case ST_GENERIC: 1991 p = "GENERIC"; 1992 break; 1993 case ST_GOTO: 1994 p = "GOTO"; 1995 break; 1996 case ST_IF_BLOCK: 1997 p = _("block IF"); 1998 break; 1999 case ST_IMPLICIT: 2000 p = "IMPLICIT"; 2001 break; 2002 case ST_IMPLICIT_NONE: 2003 p = "IMPLICIT NONE"; 2004 break; 2005 case ST_IMPLIED_ENDDO: 2006 p = _("implied END DO"); 2007 break; 2008 case ST_IMPORT: 2009 p = "IMPORT"; 2010 break; 2011 case ST_INQUIRE: 2012 p = "INQUIRE"; 2013 break; 2014 case ST_INTERFACE: 2015 p = "INTERFACE"; 2016 break; 2017 case ST_LOCK: 2018 p = "LOCK"; 2019 break; 2020 case ST_PARAMETER: 2021 p = "PARAMETER"; 2022 break; 2023 case ST_PRIVATE: 2024 p = "PRIVATE"; 2025 break; 2026 case ST_PUBLIC: 2027 p = "PUBLIC"; 2028 break; 2029 case ST_MODULE: 2030 p = "MODULE"; 2031 break; 2032 case ST_SUBMODULE: 2033 p = "SUBMODULE"; 2034 break; 2035 case ST_PAUSE: 2036 p = "PAUSE"; 2037 break; 2038 case ST_MODULE_PROC: 2039 p = "MODULE PROCEDURE"; 2040 break; 2041 case ST_NAMELIST: 2042 p = "NAMELIST"; 2043 break; 2044 case ST_NULLIFY: 2045 p = "NULLIFY"; 2046 break; 2047 case ST_OPEN: 2048 p = "OPEN"; 2049 break; 2050 case ST_PROGRAM: 2051 p = "PROGRAM"; 2052 break; 2053 case ST_PROCEDURE: 2054 p = "PROCEDURE"; 2055 break; 2056 case ST_READ: 2057 p = "READ"; 2058 break; 2059 case ST_RETURN: 2060 p = "RETURN"; 2061 break; 2062 case ST_REWIND: 2063 p = "REWIND"; 2064 break; 2065 case ST_STOP: 2066 p = "STOP"; 2067 break; 2068 case ST_SYNC_ALL: 2069 p = "SYNC ALL"; 2070 break; 2071 case ST_SYNC_IMAGES: 2072 p = "SYNC IMAGES"; 2073 break; 2074 case ST_SYNC_MEMORY: 2075 p = "SYNC MEMORY"; 2076 break; 2077 case ST_SUBROUTINE: 2078 p = "SUBROUTINE"; 2079 break; 2080 case ST_TYPE: 2081 p = "TYPE"; 2082 break; 2083 case ST_UNLOCK: 2084 p = "UNLOCK"; 2085 break; 2086 case ST_USE: 2087 p = "USE"; 2088 break; 2089 case ST_WHERE_BLOCK: /* Fall through */ 2090 case ST_WHERE: 2091 p = "WHERE"; 2092 break; 2093 case ST_WAIT: 2094 p = "WAIT"; 2095 break; 2096 case ST_WRITE: 2097 p = "WRITE"; 2098 break; 2099 case ST_ASSIGNMENT: 2100 p = _("assignment"); 2101 break; 2102 case ST_POINTER_ASSIGNMENT: 2103 p = _("pointer assignment"); 2104 break; 2105 case ST_SELECT_CASE: 2106 p = "SELECT CASE"; 2107 break; 2108 case ST_SELECT_TYPE: 2109 p = "SELECT TYPE"; 2110 break; 2111 case ST_SELECT_RANK: 2112 p = "SELECT RANK"; 2113 break; 2114 case ST_TYPE_IS: 2115 p = "TYPE IS"; 2116 break; 2117 case ST_CLASS_IS: 2118 p = "CLASS IS"; 2119 break; 2120 case ST_RANK: 2121 p = "RANK"; 2122 break; 2123 case ST_SEQUENCE: 2124 p = "SEQUENCE"; 2125 break; 2126 case ST_SIMPLE_IF: 2127 p = _("simple IF"); 2128 break; 2129 case ST_STATEMENT_FUNCTION: 2130 p = "STATEMENT FUNCTION"; 2131 break; 2132 case ST_LABEL_ASSIGNMENT: 2133 p = "LABEL ASSIGNMENT"; 2134 break; 2135 case ST_ENUM: 2136 p = "ENUM DEFINITION"; 2137 break; 2138 case ST_ENUMERATOR: 2139 p = "ENUMERATOR DEFINITION"; 2140 break; 2141 case ST_END_ENUM: 2142 p = "END ENUM"; 2143 break; 2144 case ST_OACC_PARALLEL_LOOP: 2145 p = "!$ACC PARALLEL LOOP"; 2146 break; 2147 case ST_OACC_END_PARALLEL_LOOP: 2148 p = "!$ACC END PARALLEL LOOP"; 2149 break; 2150 case ST_OACC_PARALLEL: 2151 p = "!$ACC PARALLEL"; 2152 break; 2153 case ST_OACC_END_PARALLEL: 2154 p = "!$ACC END PARALLEL"; 2155 break; 2156 case ST_OACC_KERNELS: 2157 p = "!$ACC KERNELS"; 2158 break; 2159 case ST_OACC_END_KERNELS: 2160 p = "!$ACC END KERNELS"; 2161 break; 2162 case ST_OACC_KERNELS_LOOP: 2163 p = "!$ACC KERNELS LOOP"; 2164 break; 2165 case ST_OACC_END_KERNELS_LOOP: 2166 p = "!$ACC END KERNELS LOOP"; 2167 break; 2168 case ST_OACC_SERIAL_LOOP: 2169 p = "!$ACC SERIAL LOOP"; 2170 break; 2171 case ST_OACC_END_SERIAL_LOOP: 2172 p = "!$ACC END SERIAL LOOP"; 2173 break; 2174 case ST_OACC_SERIAL: 2175 p = "!$ACC SERIAL"; 2176 break; 2177 case ST_OACC_END_SERIAL: 2178 p = "!$ACC END SERIAL"; 2179 break; 2180 case ST_OACC_DATA: 2181 p = "!$ACC DATA"; 2182 break; 2183 case ST_OACC_END_DATA: 2184 p = "!$ACC END DATA"; 2185 break; 2186 case ST_OACC_HOST_DATA: 2187 p = "!$ACC HOST_DATA"; 2188 break; 2189 case ST_OACC_END_HOST_DATA: 2190 p = "!$ACC END HOST_DATA"; 2191 break; 2192 case ST_OACC_LOOP: 2193 p = "!$ACC LOOP"; 2194 break; 2195 case ST_OACC_END_LOOP: 2196 p = "!$ACC END LOOP"; 2197 break; 2198 case ST_OACC_DECLARE: 2199 p = "!$ACC DECLARE"; 2200 break; 2201 case ST_OACC_UPDATE: 2202 p = "!$ACC UPDATE"; 2203 break; 2204 case ST_OACC_WAIT: 2205 p = "!$ACC WAIT"; 2206 break; 2207 case ST_OACC_CACHE: 2208 p = "!$ACC CACHE"; 2209 break; 2210 case ST_OACC_ENTER_DATA: 2211 p = "!$ACC ENTER DATA"; 2212 break; 2213 case ST_OACC_EXIT_DATA: 2214 p = "!$ACC EXIT DATA"; 2215 break; 2216 case ST_OACC_ROUTINE: 2217 p = "!$ACC ROUTINE"; 2218 break; 2219 case ST_OACC_ATOMIC: 2220 p = "!$ACC ATOMIC"; 2221 break; 2222 case ST_OACC_END_ATOMIC: 2223 p = "!$ACC END ATOMIC"; 2224 break; 2225 case ST_OMP_ATOMIC: 2226 p = "!$OMP ATOMIC"; 2227 break; 2228 case ST_OMP_BARRIER: 2229 p = "!$OMP BARRIER"; 2230 break; 2231 case ST_OMP_CANCEL: 2232 p = "!$OMP CANCEL"; 2233 break; 2234 case ST_OMP_CANCELLATION_POINT: 2235 p = "!$OMP CANCELLATION POINT"; 2236 break; 2237 case ST_OMP_CRITICAL: 2238 p = "!$OMP CRITICAL"; 2239 break; 2240 case ST_OMP_DECLARE_REDUCTION: 2241 p = "!$OMP DECLARE REDUCTION"; 2242 break; 2243 case ST_OMP_DECLARE_SIMD: 2244 p = "!$OMP DECLARE SIMD"; 2245 break; 2246 case ST_OMP_DECLARE_TARGET: 2247 p = "!$OMP DECLARE TARGET"; 2248 break; 2249 case ST_OMP_DISTRIBUTE: 2250 p = "!$OMP DISTRIBUTE"; 2251 break; 2252 case ST_OMP_DISTRIBUTE_PARALLEL_DO: 2253 p = "!$OMP DISTRIBUTE PARALLEL DO"; 2254 break; 2255 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 2256 p = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; 2257 break; 2258 case ST_OMP_DISTRIBUTE_SIMD: 2259 p = "!$OMP DISTRIBUTE SIMD"; 2260 break; 2261 case ST_OMP_DO: 2262 p = "!$OMP DO"; 2263 break; 2264 case ST_OMP_DO_SIMD: 2265 p = "!$OMP DO SIMD"; 2266 break; 2267 case ST_OMP_END_ATOMIC: 2268 p = "!$OMP END ATOMIC"; 2269 break; 2270 case ST_OMP_END_CRITICAL: 2271 p = "!$OMP END CRITICAL"; 2272 break; 2273 case ST_OMP_END_DISTRIBUTE: 2274 p = "!$OMP END DISTRIBUTE"; 2275 break; 2276 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO: 2277 p = "!$OMP END DISTRIBUTE PARALLEL DO"; 2278 break; 2279 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD: 2280 p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD"; 2281 break; 2282 case ST_OMP_END_DISTRIBUTE_SIMD: 2283 p = "!$OMP END DISTRIBUTE SIMD"; 2284 break; 2285 case ST_OMP_END_DO: 2286 p = "!$OMP END DO"; 2287 break; 2288 case ST_OMP_END_DO_SIMD: 2289 p = "!$OMP END DO SIMD"; 2290 break; 2291 case ST_OMP_END_SIMD: 2292 p = "!$OMP END SIMD"; 2293 break; 2294 case ST_OMP_END_MASTER: 2295 p = "!$OMP END MASTER"; 2296 break; 2297 case ST_OMP_END_ORDERED: 2298 p = "!$OMP END ORDERED"; 2299 break; 2300 case ST_OMP_END_PARALLEL: 2301 p = "!$OMP END PARALLEL"; 2302 break; 2303 case ST_OMP_END_PARALLEL_DO: 2304 p = "!$OMP END PARALLEL DO"; 2305 break; 2306 case ST_OMP_END_PARALLEL_DO_SIMD: 2307 p = "!$OMP END PARALLEL DO SIMD"; 2308 break; 2309 case ST_OMP_END_PARALLEL_SECTIONS: 2310 p = "!$OMP END PARALLEL SECTIONS"; 2311 break; 2312 case ST_OMP_END_PARALLEL_WORKSHARE: 2313 p = "!$OMP END PARALLEL WORKSHARE"; 2314 break; 2315 case ST_OMP_END_SECTIONS: 2316 p = "!$OMP END SECTIONS"; 2317 break; 2318 case ST_OMP_END_SINGLE: 2319 p = "!$OMP END SINGLE"; 2320 break; 2321 case ST_OMP_END_TASK: 2322 p = "!$OMP END TASK"; 2323 break; 2324 case ST_OMP_END_TARGET: 2325 p = "!$OMP END TARGET"; 2326 break; 2327 case ST_OMP_END_TARGET_DATA: 2328 p = "!$OMP END TARGET DATA"; 2329 break; 2330 case ST_OMP_END_TARGET_PARALLEL: 2331 p = "!$OMP END TARGET PARALLEL"; 2332 break; 2333 case ST_OMP_END_TARGET_PARALLEL_DO: 2334 p = "!$OMP END TARGET PARALLEL DO"; 2335 break; 2336 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD: 2337 p = "!$OMP END TARGET PARALLEL DO SIMD"; 2338 break; 2339 case ST_OMP_END_TARGET_SIMD: 2340 p = "!$OMP END TARGET SIMD"; 2341 break; 2342 case ST_OMP_END_TARGET_TEAMS: 2343 p = "!$OMP END TARGET TEAMS"; 2344 break; 2345 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE: 2346 p = "!$OMP END TARGET TEAMS DISTRIBUTE"; 2347 break; 2348 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 2349 p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO"; 2350 break; 2351 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2352 p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; 2353 break; 2354 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD: 2355 p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD"; 2356 break; 2357 case ST_OMP_END_TASKGROUP: 2358 p = "!$OMP END TASKGROUP"; 2359 break; 2360 case ST_OMP_END_TASKLOOP: 2361 p = "!$OMP END TASKLOOP"; 2362 break; 2363 case ST_OMP_END_TASKLOOP_SIMD: 2364 p = "!$OMP END TASKLOOP SIMD"; 2365 break; 2366 case ST_OMP_END_TEAMS: 2367 p = "!$OMP END TEAMS"; 2368 break; 2369 case ST_OMP_END_TEAMS_DISTRIBUTE: 2370 p = "!$OMP END TEAMS DISTRIBUTE"; 2371 break; 2372 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO: 2373 p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO"; 2374 break; 2375 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2376 p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD"; 2377 break; 2378 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD: 2379 p = "!$OMP END TEAMS DISTRIBUTE SIMD"; 2380 break; 2381 case ST_OMP_END_WORKSHARE: 2382 p = "!$OMP END WORKSHARE"; 2383 break; 2384 case ST_OMP_FLUSH: 2385 p = "!$OMP FLUSH"; 2386 break; 2387 case ST_OMP_MASTER: 2388 p = "!$OMP MASTER"; 2389 break; 2390 case ST_OMP_ORDERED: 2391 case ST_OMP_ORDERED_DEPEND: 2392 p = "!$OMP ORDERED"; 2393 break; 2394 case ST_OMP_PARALLEL: 2395 p = "!$OMP PARALLEL"; 2396 break; 2397 case ST_OMP_PARALLEL_DO: 2398 p = "!$OMP PARALLEL DO"; 2399 break; 2400 case ST_OMP_PARALLEL_DO_SIMD: 2401 p = "!$OMP PARALLEL DO SIMD"; 2402 break; 2403 case ST_OMP_PARALLEL_SECTIONS: 2404 p = "!$OMP PARALLEL SECTIONS"; 2405 break; 2406 case ST_OMP_PARALLEL_WORKSHARE: 2407 p = "!$OMP PARALLEL WORKSHARE"; 2408 break; 2409 case ST_OMP_SECTIONS: 2410 p = "!$OMP SECTIONS"; 2411 break; 2412 case ST_OMP_SECTION: 2413 p = "!$OMP SECTION"; 2414 break; 2415 case ST_OMP_SIMD: 2416 p = "!$OMP SIMD"; 2417 break; 2418 case ST_OMP_SINGLE: 2419 p = "!$OMP SINGLE"; 2420 break; 2421 case ST_OMP_TARGET: 2422 p = "!$OMP TARGET"; 2423 break; 2424 case ST_OMP_TARGET_DATA: 2425 p = "!$OMP TARGET DATA"; 2426 break; 2427 case ST_OMP_TARGET_ENTER_DATA: 2428 p = "!$OMP TARGET ENTER DATA"; 2429 break; 2430 case ST_OMP_TARGET_EXIT_DATA: 2431 p = "!$OMP TARGET EXIT DATA"; 2432 break; 2433 case ST_OMP_TARGET_PARALLEL: 2434 p = "!$OMP TARGET PARALLEL"; 2435 break; 2436 case ST_OMP_TARGET_PARALLEL_DO: 2437 p = "!$OMP TARGET PARALLEL DO"; 2438 break; 2439 case ST_OMP_TARGET_PARALLEL_DO_SIMD: 2440 p = "!$OMP TARGET PARALLEL DO SIMD"; 2441 break; 2442 case ST_OMP_TARGET_SIMD: 2443 p = "!$OMP TARGET SIMD"; 2444 break; 2445 case ST_OMP_TARGET_TEAMS: 2446 p = "!$OMP TARGET TEAMS"; 2447 break; 2448 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: 2449 p = "!$OMP TARGET TEAMS DISTRIBUTE"; 2450 break; 2451 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 2452 p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; 2453 break; 2454 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2455 p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; 2456 break; 2457 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 2458 p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; 2459 break; 2460 case ST_OMP_TARGET_UPDATE: 2461 p = "!$OMP TARGET UPDATE"; 2462 break; 2463 case ST_OMP_TASK: 2464 p = "!$OMP TASK"; 2465 break; 2466 case ST_OMP_TASKGROUP: 2467 p = "!$OMP TASKGROUP"; 2468 break; 2469 case ST_OMP_TASKLOOP: 2470 p = "!$OMP TASKLOOP"; 2471 break; 2472 case ST_OMP_TASKLOOP_SIMD: 2473 p = "!$OMP TASKLOOP SIMD"; 2474 break; 2475 case ST_OMP_TASKWAIT: 2476 p = "!$OMP TASKWAIT"; 2477 break; 2478 case ST_OMP_TASKYIELD: 2479 p = "!$OMP TASKYIELD"; 2480 break; 2481 case ST_OMP_TEAMS: 2482 p = "!$OMP TEAMS"; 2483 break; 2484 case ST_OMP_TEAMS_DISTRIBUTE: 2485 p = "!$OMP TEAMS DISTRIBUTE"; 2486 break; 2487 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 2488 p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; 2489 break; 2490 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2491 p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; 2492 break; 2493 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: 2494 p = "!$OMP TEAMS DISTRIBUTE SIMD"; 2495 break; 2496 case ST_OMP_THREADPRIVATE: 2497 p = "!$OMP THREADPRIVATE"; 2498 break; 2499 case ST_OMP_WORKSHARE: 2500 p = "!$OMP WORKSHARE"; 2501 break; 2502 default: 2503 gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); 2504 } 2505 2506 return p; 2507 } 2508 2509 2510 /* Create a symbol for the main program and assign it to ns->proc_name. */ 2511 2512 static void 2513 main_program_symbol (gfc_namespace *ns, const char *name) 2514 { 2515 gfc_symbol *main_program; 2516 symbol_attribute attr; 2517 2518 gfc_get_symbol (name, ns, &main_program); 2519 gfc_clear_attr (&attr); 2520 attr.flavor = FL_PROGRAM; 2521 attr.proc = PROC_UNKNOWN; 2522 attr.subroutine = 1; 2523 attr.access = ACCESS_PUBLIC; 2524 attr.is_main_program = 1; 2525 main_program->attr = attr; 2526 main_program->declared_at = gfc_current_locus; 2527 ns->proc_name = main_program; 2528 gfc_commit_symbols (); 2529 } 2530 2531 2532 /* Do whatever is necessary to accept the last statement. */ 2533 2534 static void 2535 accept_statement (gfc_statement st) 2536 { 2537 switch (st) 2538 { 2539 case ST_IMPLICIT_NONE: 2540 case ST_IMPLICIT: 2541 break; 2542 2543 case ST_FUNCTION: 2544 case ST_SUBROUTINE: 2545 case ST_MODULE: 2546 case ST_SUBMODULE: 2547 gfc_current_ns->proc_name = gfc_new_block; 2548 break; 2549 2550 /* If the statement is the end of a block, lay down a special code 2551 that allows a branch to the end of the block from within the 2552 construct. IF and SELECT are treated differently from DO 2553 (where EXEC_NOP is added inside the loop) for two 2554 reasons: 2555 1. END DO has a meaning in the sense that after a GOTO to 2556 it, the loop counter must be increased. 2557 2. IF blocks and SELECT blocks can consist of multiple 2558 parallel blocks (IF ... ELSE IF ... ELSE ... END IF). 2559 Putting the label before the END IF would make the jump 2560 from, say, the ELSE IF block to the END IF illegal. */ 2561 2562 case ST_ENDIF: 2563 case ST_END_SELECT: 2564 case ST_END_CRITICAL: 2565 if (gfc_statement_label != NULL) 2566 { 2567 new_st.op = EXEC_END_NESTED_BLOCK; 2568 add_statement (); 2569 } 2570 break; 2571 2572 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than 2573 one parallel block. Thus, we add the special code to the nested block 2574 itself, instead of the parent one. */ 2575 case ST_END_BLOCK: 2576 case ST_END_ASSOCIATE: 2577 if (gfc_statement_label != NULL) 2578 { 2579 new_st.op = EXEC_END_BLOCK; 2580 add_statement (); 2581 } 2582 break; 2583 2584 /* The end-of-program unit statements do not get the special 2585 marker and require a statement of some sort if they are a 2586 branch target. */ 2587 2588 case ST_END_PROGRAM: 2589 case ST_END_FUNCTION: 2590 case ST_END_SUBROUTINE: 2591 if (gfc_statement_label != NULL) 2592 { 2593 new_st.op = EXEC_RETURN; 2594 add_statement (); 2595 } 2596 else 2597 { 2598 new_st.op = EXEC_END_PROCEDURE; 2599 add_statement (); 2600 } 2601 2602 break; 2603 2604 case ST_ENTRY: 2605 case_executable: 2606 case_exec_markers: 2607 add_statement (); 2608 break; 2609 2610 default: 2611 break; 2612 } 2613 2614 gfc_commit_symbols (); 2615 gfc_warning_check (); 2616 gfc_clear_new_st (); 2617 } 2618 2619 2620 /* Undo anything tentative that has been built for the current statement, 2621 except if a gfc_charlen structure has been added to current namespace's 2622 list of gfc_charlen structure. */ 2623 2624 static void 2625 reject_statement (void) 2626 { 2627 gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv); 2628 gfc_current_ns->equiv = gfc_current_ns->old_equiv; 2629 2630 gfc_reject_data (gfc_current_ns); 2631 2632 gfc_new_block = NULL; 2633 gfc_undo_symbols (); 2634 gfc_clear_warning (); 2635 undo_new_statement (); 2636 } 2637 2638 2639 /* Generic complaint about an out of order statement. We also do 2640 whatever is necessary to clean up. */ 2641 2642 static void 2643 unexpected_statement (gfc_statement st) 2644 { 2645 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); 2646 2647 reject_statement (); 2648 } 2649 2650 2651 /* Given the next statement seen by the matcher, make sure that it is 2652 in proper order with the last. This subroutine is initialized by 2653 calling it with an argument of ST_NONE. If there is a problem, we 2654 issue an error and return false. Otherwise we return true. 2655 2656 Individual parsers need to verify that the statements seen are 2657 valid before calling here, i.e., ENTRY statements are not allowed in 2658 INTERFACE blocks. The following diagram is taken from the standard: 2659 2660 +---------------------------------------+ 2661 | program subroutine function module | 2662 +---------------------------------------+ 2663 | use | 2664 +---------------------------------------+ 2665 | import | 2666 +---------------------------------------+ 2667 | | implicit none | 2668 | +-----------+------------------+ 2669 | | parameter | implicit | 2670 | +-----------+------------------+ 2671 | format | | derived type | 2672 | entry | parameter | interface | 2673 | | data | specification | 2674 | | | statement func | 2675 | +-----------+------------------+ 2676 | | data | executable | 2677 +--------+-----------+------------------+ 2678 | contains | 2679 +---------------------------------------+ 2680 | internal module/subprogram | 2681 +---------------------------------------+ 2682 | end | 2683 +---------------------------------------+ 2684 2685 */ 2686 2687 enum state_order 2688 { 2689 ORDER_START, 2690 ORDER_USE, 2691 ORDER_IMPORT, 2692 ORDER_IMPLICIT_NONE, 2693 ORDER_IMPLICIT, 2694 ORDER_SPEC, 2695 ORDER_EXEC 2696 }; 2697 2698 typedef struct 2699 { 2700 enum state_order state; 2701 gfc_statement last_statement; 2702 locus where; 2703 } 2704 st_state; 2705 2706 static bool 2707 verify_st_order (st_state *p, gfc_statement st, bool silent) 2708 { 2709 2710 switch (st) 2711 { 2712 case ST_NONE: 2713 p->state = ORDER_START; 2714 break; 2715 2716 case ST_USE: 2717 if (p->state > ORDER_USE) 2718 goto order; 2719 p->state = ORDER_USE; 2720 break; 2721 2722 case ST_IMPORT: 2723 if (p->state > ORDER_IMPORT) 2724 goto order; 2725 p->state = ORDER_IMPORT; 2726 break; 2727 2728 case ST_IMPLICIT_NONE: 2729 if (p->state > ORDER_IMPLICIT) 2730 goto order; 2731 2732 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY 2733 statement disqualifies a USE but not an IMPLICIT NONE. 2734 Duplicate IMPLICIT NONEs are caught when the implicit types 2735 are set. */ 2736 2737 p->state = ORDER_IMPLICIT_NONE; 2738 break; 2739 2740 case ST_IMPLICIT: 2741 if (p->state > ORDER_IMPLICIT) 2742 goto order; 2743 p->state = ORDER_IMPLICIT; 2744 break; 2745 2746 case ST_FORMAT: 2747 case ST_ENTRY: 2748 if (p->state < ORDER_IMPLICIT_NONE) 2749 p->state = ORDER_IMPLICIT_NONE; 2750 break; 2751 2752 case ST_PARAMETER: 2753 if (p->state >= ORDER_EXEC) 2754 goto order; 2755 if (p->state < ORDER_IMPLICIT) 2756 p->state = ORDER_IMPLICIT; 2757 break; 2758 2759 case ST_DATA: 2760 if (p->state < ORDER_SPEC) 2761 p->state = ORDER_SPEC; 2762 break; 2763 2764 case ST_PUBLIC: 2765 case ST_PRIVATE: 2766 case ST_STRUCTURE_DECL: 2767 case ST_DERIVED_DECL: 2768 case_decl: 2769 if (p->state >= ORDER_EXEC) 2770 goto order; 2771 if (p->state < ORDER_SPEC) 2772 p->state = ORDER_SPEC; 2773 break; 2774 2775 case_omp_decl: 2776 /* The OpenMP directives have to be somewhere in the specification 2777 part, but there are no further requirements on their ordering. 2778 Thus don't adjust p->state, just ignore them. */ 2779 if (p->state >= ORDER_EXEC) 2780 goto order; 2781 break; 2782 2783 case_executable: 2784 case_exec_markers: 2785 if (p->state < ORDER_EXEC) 2786 p->state = ORDER_EXEC; 2787 break; 2788 2789 default: 2790 return false; 2791 } 2792 2793 /* All is well, record the statement in case we need it next time. */ 2794 p->where = gfc_current_locus; 2795 p->last_statement = st; 2796 return true; 2797 2798 order: 2799 if (!silent) 2800 gfc_error ("%s statement at %C cannot follow %s statement at %L", 2801 gfc_ascii_statement (st), 2802 gfc_ascii_statement (p->last_statement), &p->where); 2803 2804 return false; 2805 } 2806 2807 2808 /* Handle an unexpected end of file. This is a show-stopper... */ 2809 2810 static void unexpected_eof (void) ATTRIBUTE_NORETURN; 2811 2812 static void 2813 unexpected_eof (void) 2814 { 2815 gfc_state_data *p; 2816 2817 gfc_error ("Unexpected end of file in %qs", gfc_source_file); 2818 2819 /* Memory cleanup. Move to "second to last". */ 2820 for (p = gfc_state_stack; p && p->previous && p->previous->previous; 2821 p = p->previous); 2822 2823 gfc_current_ns->code = (p && p->previous) ? p->head : NULL; 2824 gfc_done_2 (); 2825 2826 longjmp (eof_buf, 1); 2827 2828 /* Avoids build error on systems where longjmp is not declared noreturn. */ 2829 gcc_unreachable (); 2830 } 2831 2832 2833 /* Parse the CONTAINS section of a derived type definition. */ 2834 2835 gfc_access gfc_typebound_default_access; 2836 2837 static bool 2838 parse_derived_contains (void) 2839 { 2840 gfc_state_data s; 2841 bool seen_private = false; 2842 bool seen_comps = false; 2843 bool error_flag = false; 2844 bool to_finish; 2845 2846 gcc_assert (gfc_current_state () == COMP_DERIVED); 2847 gcc_assert (gfc_current_block ()); 2848 2849 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS 2850 section. */ 2851 if (gfc_current_block ()->attr.sequence) 2852 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS" 2853 " section at %C", gfc_current_block ()->name); 2854 if (gfc_current_block ()->attr.is_bind_c) 2855 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS" 2856 " section at %C", gfc_current_block ()->name); 2857 2858 accept_statement (ST_CONTAINS); 2859 push_state (&s, COMP_DERIVED_CONTAINS, NULL); 2860 2861 gfc_typebound_default_access = ACCESS_PUBLIC; 2862 2863 to_finish = false; 2864 while (!to_finish) 2865 { 2866 gfc_statement st; 2867 st = next_statement (); 2868 switch (st) 2869 { 2870 case ST_NONE: 2871 unexpected_eof (); 2872 break; 2873 2874 case ST_DATA_DECL: 2875 gfc_error ("Components in TYPE at %C must precede CONTAINS"); 2876 goto error; 2877 2878 case ST_PROCEDURE: 2879 if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C")) 2880 goto error; 2881 2882 accept_statement (ST_PROCEDURE); 2883 seen_comps = true; 2884 break; 2885 2886 case ST_GENERIC: 2887 if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C")) 2888 goto error; 2889 2890 accept_statement (ST_GENERIC); 2891 seen_comps = true; 2892 break; 2893 2894 case ST_FINAL: 2895 if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration" 2896 " at %C")) 2897 goto error; 2898 2899 accept_statement (ST_FINAL); 2900 seen_comps = true; 2901 break; 2902 2903 case ST_END_TYPE: 2904 to_finish = true; 2905 2906 if (!seen_comps 2907 && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition " 2908 "at %C with empty CONTAINS section"))) 2909 goto error; 2910 2911 /* ST_END_TYPE is accepted by parse_derived after return. */ 2912 break; 2913 2914 case ST_PRIVATE: 2915 if (!gfc_find_state (COMP_MODULE)) 2916 { 2917 gfc_error ("PRIVATE statement in TYPE at %C must be inside " 2918 "a MODULE"); 2919 goto error; 2920 } 2921 2922 if (seen_comps) 2923 { 2924 gfc_error ("PRIVATE statement at %C must precede procedure" 2925 " bindings"); 2926 goto error; 2927 } 2928 2929 if (seen_private) 2930 { 2931 gfc_error ("Duplicate PRIVATE statement at %C"); 2932 goto error; 2933 } 2934 2935 accept_statement (ST_PRIVATE); 2936 gfc_typebound_default_access = ACCESS_PRIVATE; 2937 seen_private = true; 2938 break; 2939 2940 case ST_SEQUENCE: 2941 gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); 2942 goto error; 2943 2944 case ST_CONTAINS: 2945 gfc_error ("Already inside a CONTAINS block at %C"); 2946 goto error; 2947 2948 default: 2949 unexpected_statement (st); 2950 break; 2951 } 2952 2953 continue; 2954 2955 error: 2956 error_flag = true; 2957 reject_statement (); 2958 } 2959 2960 pop_state (); 2961 gcc_assert (gfc_current_state () == COMP_DERIVED); 2962 2963 return error_flag; 2964 } 2965 2966 2967 /* Set attributes for the parent symbol based on the attributes of a component 2968 and raise errors if conflicting attributes are found for the component. */ 2969 2970 static void 2971 check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp, 2972 gfc_component **eventp) 2973 { 2974 bool coarray, lock_type, event_type, allocatable, pointer; 2975 coarray = lock_type = event_type = allocatable = pointer = false; 2976 gfc_component *lock_comp = NULL, *event_comp = NULL; 2977 2978 if (lockp) lock_comp = *lockp; 2979 if (eventp) event_comp = *eventp; 2980 2981 /* Look for allocatable components. */ 2982 if (c->attr.allocatable 2983 || (c->ts.type == BT_CLASS && c->attr.class_ok 2984 && CLASS_DATA (c)->attr.allocatable) 2985 || (c->ts.type == BT_DERIVED && !c->attr.pointer 2986 && c->ts.u.derived->attr.alloc_comp)) 2987 { 2988 allocatable = true; 2989 sym->attr.alloc_comp = 1; 2990 } 2991 2992 /* Look for pointer components. */ 2993 if (c->attr.pointer 2994 || (c->ts.type == BT_CLASS && c->attr.class_ok 2995 && CLASS_DATA (c)->attr.class_pointer) 2996 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) 2997 { 2998 pointer = true; 2999 sym->attr.pointer_comp = 1; 3000 } 3001 3002 /* Look for procedure pointer components. */ 3003 if (c->attr.proc_pointer 3004 || (c->ts.type == BT_DERIVED 3005 && c->ts.u.derived->attr.proc_pointer_comp)) 3006 sym->attr.proc_pointer_comp = 1; 3007 3008 /* Looking for coarray components. */ 3009 if (c->attr.codimension 3010 || (c->ts.type == BT_CLASS && c->attr.class_ok 3011 && CLASS_DATA (c)->attr.codimension)) 3012 { 3013 coarray = true; 3014 sym->attr.coarray_comp = 1; 3015 } 3016 3017 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp 3018 && !c->attr.pointer) 3019 { 3020 coarray = true; 3021 sym->attr.coarray_comp = 1; 3022 } 3023 3024 /* Looking for lock_type components. */ 3025 if ((c->ts.type == BT_DERIVED 3026 && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 3027 && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 3028 || (c->ts.type == BT_CLASS && c->attr.class_ok 3029 && CLASS_DATA (c)->ts.u.derived->from_intmod 3030 == INTMOD_ISO_FORTRAN_ENV 3031 && CLASS_DATA (c)->ts.u.derived->intmod_sym_id 3032 == ISOFORTRAN_LOCK_TYPE) 3033 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp 3034 && !allocatable && !pointer)) 3035 { 3036 lock_type = 1; 3037 lock_comp = c; 3038 sym->attr.lock_comp = 1; 3039 } 3040 3041 /* Looking for event_type components. */ 3042 if ((c->ts.type == BT_DERIVED 3043 && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 3044 && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 3045 || (c->ts.type == BT_CLASS && c->attr.class_ok 3046 && CLASS_DATA (c)->ts.u.derived->from_intmod 3047 == INTMOD_ISO_FORTRAN_ENV 3048 && CLASS_DATA (c)->ts.u.derived->intmod_sym_id 3049 == ISOFORTRAN_EVENT_TYPE) 3050 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp 3051 && !allocatable && !pointer)) 3052 { 3053 event_type = 1; 3054 event_comp = c; 3055 sym->attr.event_comp = 1; 3056 } 3057 3058 /* Check for F2008, C1302 - and recall that pointers may not be coarrays 3059 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7), 3060 unless there are nondirect [allocatable or pointer] components 3061 involved (cf. 1.3.33.1 and 1.3.33.3). */ 3062 3063 if (pointer && !coarray && lock_type) 3064 gfc_error ("Component %s at %L of type LOCK_TYPE must have a " 3065 "codimension or be a subcomponent of a coarray, " 3066 "which is not possible as the component has the " 3067 "pointer attribute", c->name, &c->loc); 3068 else if (pointer && !coarray && c->ts.type == BT_DERIVED 3069 && c->ts.u.derived->attr.lock_comp) 3070 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " 3071 "of type LOCK_TYPE, which must have a codimension or be a " 3072 "subcomponent of a coarray", c->name, &c->loc); 3073 3074 if (lock_type && allocatable && !coarray) 3075 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have " 3076 "a codimension", c->name, &c->loc); 3077 else if (lock_type && allocatable && c->ts.type == BT_DERIVED 3078 && c->ts.u.derived->attr.lock_comp) 3079 gfc_error ("Allocatable component %s at %L must have a codimension as " 3080 "it has a noncoarray subcomponent of type LOCK_TYPE", 3081 c->name, &c->loc); 3082 3083 if (sym->attr.coarray_comp && !coarray && lock_type) 3084 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " 3085 "subcomponent of type LOCK_TYPE must have a codimension or " 3086 "be a subcomponent of a coarray. (Variables of type %s may " 3087 "not have a codimension as already a coarray " 3088 "subcomponent exists)", c->name, &c->loc, sym->name); 3089 3090 if (sym->attr.lock_comp && coarray && !lock_type) 3091 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " 3092 "subcomponent of type LOCK_TYPE must have a codimension or " 3093 "be a subcomponent of a coarray. (Variables of type %s may " 3094 "not have a codimension as %s at %L has a codimension or a " 3095 "coarray subcomponent)", lock_comp->name, &lock_comp->loc, 3096 sym->name, c->name, &c->loc); 3097 3098 /* Similarly for EVENT TYPE. */ 3099 3100 if (pointer && !coarray && event_type) 3101 gfc_error ("Component %s at %L of type EVENT_TYPE must have a " 3102 "codimension or be a subcomponent of a coarray, " 3103 "which is not possible as the component has the " 3104 "pointer attribute", c->name, &c->loc); 3105 else if (pointer && !coarray && c->ts.type == BT_DERIVED 3106 && c->ts.u.derived->attr.event_comp) 3107 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " 3108 "of type EVENT_TYPE, which must have a codimension or be a " 3109 "subcomponent of a coarray", c->name, &c->loc); 3110 3111 if (event_type && allocatable && !coarray) 3112 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have " 3113 "a codimension", c->name, &c->loc); 3114 else if (event_type && allocatable && c->ts.type == BT_DERIVED 3115 && c->ts.u.derived->attr.event_comp) 3116 gfc_error ("Allocatable component %s at %L must have a codimension as " 3117 "it has a noncoarray subcomponent of type EVENT_TYPE", 3118 c->name, &c->loc); 3119 3120 if (sym->attr.coarray_comp && !coarray && event_type) 3121 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " 3122 "subcomponent of type EVENT_TYPE must have a codimension or " 3123 "be a subcomponent of a coarray. (Variables of type %s may " 3124 "not have a codimension as already a coarray " 3125 "subcomponent exists)", c->name, &c->loc, sym->name); 3126 3127 if (sym->attr.event_comp && coarray && !event_type) 3128 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " 3129 "subcomponent of type EVENT_TYPE must have a codimension or " 3130 "be a subcomponent of a coarray. (Variables of type %s may " 3131 "not have a codimension as %s at %L has a codimension or a " 3132 "coarray subcomponent)", event_comp->name, &event_comp->loc, 3133 sym->name, c->name, &c->loc); 3134 3135 /* Look for private components. */ 3136 if (sym->component_access == ACCESS_PRIVATE 3137 || c->attr.access == ACCESS_PRIVATE 3138 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp)) 3139 sym->attr.private_comp = 1; 3140 3141 if (lockp) *lockp = lock_comp; 3142 if (eventp) *eventp = event_comp; 3143 } 3144 3145 3146 static void parse_struct_map (gfc_statement); 3147 3148 /* Parse a union component definition within a structure definition. */ 3149 3150 static void 3151 parse_union (void) 3152 { 3153 int compiling; 3154 gfc_statement st; 3155 gfc_state_data s; 3156 gfc_component *c, *lock_comp = NULL, *event_comp = NULL; 3157 gfc_symbol *un; 3158 3159 accept_statement(ST_UNION); 3160 push_state (&s, COMP_UNION, gfc_new_block); 3161 un = gfc_new_block; 3162 3163 compiling = 1; 3164 3165 while (compiling) 3166 { 3167 st = next_statement (); 3168 /* Only MAP declarations valid within a union. */ 3169 switch (st) 3170 { 3171 case ST_NONE: 3172 unexpected_eof (); 3173 3174 case ST_MAP: 3175 accept_statement (ST_MAP); 3176 parse_struct_map (ST_MAP); 3177 /* Add a component to the union for each map. */ 3178 if (!gfc_add_component (un, gfc_new_block->name, &c)) 3179 { 3180 gfc_internal_error ("failed to create map component '%s'", 3181 gfc_new_block->name); 3182 reject_statement (); 3183 return; 3184 } 3185 c->ts.type = BT_DERIVED; 3186 c->ts.u.derived = gfc_new_block; 3187 /* Normally components get their initialization expressions when they 3188 are created in decl.c (build_struct) so we can look through the 3189 flat component list for initializers during resolution. Unions and 3190 maps create components along with their type definitions so we 3191 have to generate initializers here. */ 3192 c->initializer = gfc_default_initializer (&c->ts); 3193 break; 3194 3195 case ST_END_UNION: 3196 compiling = 0; 3197 accept_statement (ST_END_UNION); 3198 break; 3199 3200 default: 3201 unexpected_statement (st); 3202 break; 3203 } 3204 } 3205 3206 for (c = un->components; c; c = c->next) 3207 check_component (un, c, &lock_comp, &event_comp); 3208 3209 /* Add the union as a component in its parent structure. */ 3210 pop_state (); 3211 if (!gfc_add_component (gfc_current_block (), un->name, &c)) 3212 { 3213 gfc_internal_error ("failed to create union component '%s'", un->name); 3214 reject_statement (); 3215 return; 3216 } 3217 c->ts.type = BT_UNION; 3218 c->ts.u.derived = un; 3219 c->initializer = gfc_default_initializer (&c->ts); 3220 3221 un->attr.zero_comp = un->components == NULL; 3222 } 3223 3224 3225 /* Parse a STRUCTURE or MAP. */ 3226 3227 static void 3228 parse_struct_map (gfc_statement block) 3229 { 3230 int compiling_type; 3231 gfc_statement st; 3232 gfc_state_data s; 3233 gfc_symbol *sym; 3234 gfc_component *c, *lock_comp = NULL, *event_comp = NULL; 3235 gfc_compile_state comp; 3236 gfc_statement ends; 3237 3238 if (block == ST_STRUCTURE_DECL) 3239 { 3240 comp = COMP_STRUCTURE; 3241 ends = ST_END_STRUCTURE; 3242 } 3243 else 3244 { 3245 gcc_assert (block == ST_MAP); 3246 comp = COMP_MAP; 3247 ends = ST_END_MAP; 3248 } 3249 3250 accept_statement(block); 3251 push_state (&s, comp, gfc_new_block); 3252 3253 gfc_new_block->component_access = ACCESS_PUBLIC; 3254 compiling_type = 1; 3255 3256 while (compiling_type) 3257 { 3258 st = next_statement (); 3259 switch (st) 3260 { 3261 case ST_NONE: 3262 unexpected_eof (); 3263 3264 /* Nested structure declarations will be captured as ST_DATA_DECL. */ 3265 case ST_STRUCTURE_DECL: 3266 /* Let a more specific error make it to decode_statement(). */ 3267 if (gfc_error_check () == 0) 3268 gfc_error ("Syntax error in nested structure declaration at %C"); 3269 reject_statement (); 3270 /* Skip the rest of this statement. */ 3271 gfc_error_recovery (); 3272 break; 3273 3274 case ST_UNION: 3275 accept_statement (ST_UNION); 3276 parse_union (); 3277 break; 3278 3279 case ST_DATA_DECL: 3280 /* The data declaration was a nested/ad-hoc STRUCTURE field. */ 3281 accept_statement (ST_DATA_DECL); 3282 if (gfc_new_block && gfc_new_block != gfc_current_block () 3283 && gfc_new_block->attr.flavor == FL_STRUCT) 3284 parse_struct_map (ST_STRUCTURE_DECL); 3285 break; 3286 3287 case ST_END_STRUCTURE: 3288 case ST_END_MAP: 3289 if (st == ends) 3290 { 3291 accept_statement (st); 3292 compiling_type = 0; 3293 } 3294 else 3295 unexpected_statement (st); 3296 break; 3297 3298 default: 3299 unexpected_statement (st); 3300 break; 3301 } 3302 } 3303 3304 /* Validate each component. */ 3305 sym = gfc_current_block (); 3306 for (c = sym->components; c; c = c->next) 3307 check_component (sym, c, &lock_comp, &event_comp); 3308 3309 sym->attr.zero_comp = (sym->components == NULL); 3310 3311 /* Allow parse_union to find this structure to add to its list of maps. */ 3312 if (block == ST_MAP) 3313 gfc_new_block = gfc_current_block (); 3314 3315 pop_state (); 3316 } 3317 3318 3319 /* Parse a derived type. */ 3320 3321 static void 3322 parse_derived (void) 3323 { 3324 int compiling_type, seen_private, seen_sequence, seen_component; 3325 gfc_statement st; 3326 gfc_state_data s; 3327 gfc_symbol *sym; 3328 gfc_component *c, *lock_comp = NULL, *event_comp = NULL; 3329 3330 accept_statement (ST_DERIVED_DECL); 3331 push_state (&s, COMP_DERIVED, gfc_new_block); 3332 3333 gfc_new_block->component_access = ACCESS_PUBLIC; 3334 seen_private = 0; 3335 seen_sequence = 0; 3336 seen_component = 0; 3337 3338 compiling_type = 1; 3339 3340 while (compiling_type) 3341 { 3342 st = next_statement (); 3343 switch (st) 3344 { 3345 case ST_NONE: 3346 unexpected_eof (); 3347 3348 case ST_DATA_DECL: 3349 case ST_PROCEDURE: 3350 accept_statement (st); 3351 seen_component = 1; 3352 break; 3353 3354 case ST_FINAL: 3355 gfc_error ("FINAL declaration at %C must be inside CONTAINS"); 3356 break; 3357 3358 case ST_END_TYPE: 3359 endType: 3360 compiling_type = 0; 3361 3362 if (!seen_component) 3363 gfc_notify_std (GFC_STD_F2003, "Derived type " 3364 "definition at %C without components"); 3365 3366 accept_statement (ST_END_TYPE); 3367 break; 3368 3369 case ST_PRIVATE: 3370 if (!gfc_find_state (COMP_MODULE)) 3371 { 3372 gfc_error ("PRIVATE statement in TYPE at %C must be inside " 3373 "a MODULE"); 3374 break; 3375 } 3376 3377 if (seen_component) 3378 { 3379 gfc_error ("PRIVATE statement at %C must precede " 3380 "structure components"); 3381 break; 3382 } 3383 3384 if (seen_private) 3385 gfc_error ("Duplicate PRIVATE statement at %C"); 3386 3387 s.sym->component_access = ACCESS_PRIVATE; 3388 3389 accept_statement (ST_PRIVATE); 3390 seen_private = 1; 3391 break; 3392 3393 case ST_SEQUENCE: 3394 if (seen_component) 3395 { 3396 gfc_error ("SEQUENCE statement at %C must precede " 3397 "structure components"); 3398 break; 3399 } 3400 3401 if (gfc_current_block ()->attr.sequence) 3402 gfc_warning (0, "SEQUENCE attribute at %C already specified in " 3403 "TYPE statement"); 3404 3405 if (seen_sequence) 3406 { 3407 gfc_error ("Duplicate SEQUENCE statement at %C"); 3408 } 3409 3410 seen_sequence = 1; 3411 gfc_add_sequence (&gfc_current_block ()->attr, 3412 gfc_current_block ()->name, NULL); 3413 break; 3414 3415 case ST_CONTAINS: 3416 gfc_notify_std (GFC_STD_F2003, 3417 "CONTAINS block in derived type" 3418 " definition at %C"); 3419 3420 accept_statement (ST_CONTAINS); 3421 parse_derived_contains (); 3422 goto endType; 3423 3424 default: 3425 unexpected_statement (st); 3426 break; 3427 } 3428 } 3429 3430 /* need to verify that all fields of the derived type are 3431 * interoperable with C if the type is declared to be bind(c) 3432 */ 3433 sym = gfc_current_block (); 3434 for (c = sym->components; c; c = c->next) 3435 check_component (sym, c, &lock_comp, &event_comp); 3436 3437 if (!seen_component) 3438 sym->attr.zero_comp = 1; 3439 3440 pop_state (); 3441 } 3442 3443 3444 /* Parse an ENUM. */ 3445 3446 static void 3447 parse_enum (void) 3448 { 3449 gfc_statement st; 3450 int compiling_enum; 3451 gfc_state_data s; 3452 int seen_enumerator = 0; 3453 3454 push_state (&s, COMP_ENUM, gfc_new_block); 3455 3456 compiling_enum = 1; 3457 3458 while (compiling_enum) 3459 { 3460 st = next_statement (); 3461 switch (st) 3462 { 3463 case ST_NONE: 3464 unexpected_eof (); 3465 break; 3466 3467 case ST_ENUMERATOR: 3468 seen_enumerator = 1; 3469 accept_statement (st); 3470 break; 3471 3472 case ST_END_ENUM: 3473 compiling_enum = 0; 3474 if (!seen_enumerator) 3475 gfc_error ("ENUM declaration at %C has no ENUMERATORS"); 3476 accept_statement (st); 3477 break; 3478 3479 default: 3480 gfc_free_enum_history (); 3481 unexpected_statement (st); 3482 break; 3483 } 3484 } 3485 pop_state (); 3486 } 3487 3488 3489 /* Parse an interface. We must be able to deal with the possibility 3490 of recursive interfaces. The parse_spec() subroutine is mutually 3491 recursive with parse_interface(). */ 3492 3493 static gfc_statement parse_spec (gfc_statement); 3494 3495 static void 3496 parse_interface (void) 3497 { 3498 gfc_compile_state new_state = COMP_NONE, current_state; 3499 gfc_symbol *prog_unit, *sym; 3500 gfc_interface_info save; 3501 gfc_state_data s1, s2; 3502 gfc_statement st; 3503 3504 accept_statement (ST_INTERFACE); 3505 3506 current_interface.ns = gfc_current_ns; 3507 save = current_interface; 3508 3509 sym = (current_interface.type == INTERFACE_GENERIC 3510 || current_interface.type == INTERFACE_USER_OP) 3511 ? gfc_new_block : NULL; 3512 3513 push_state (&s1, COMP_INTERFACE, sym); 3514 current_state = COMP_NONE; 3515 3516 loop: 3517 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0); 3518 3519 st = next_statement (); 3520 switch (st) 3521 { 3522 case ST_NONE: 3523 unexpected_eof (); 3524 3525 case ST_SUBROUTINE: 3526 case ST_FUNCTION: 3527 if (st == ST_SUBROUTINE) 3528 new_state = COMP_SUBROUTINE; 3529 else if (st == ST_FUNCTION) 3530 new_state = COMP_FUNCTION; 3531 if (gfc_new_block->attr.pointer) 3532 { 3533 gfc_new_block->attr.pointer = 0; 3534 gfc_new_block->attr.proc_pointer = 1; 3535 } 3536 if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, 3537 gfc_new_block->formal, NULL)) 3538 { 3539 reject_statement (); 3540 gfc_free_namespace (gfc_current_ns); 3541 goto loop; 3542 } 3543 /* F2008 C1210 forbids the IMPORT statement in module procedure 3544 interface bodies and the flag is set to import symbols. */ 3545 if (gfc_new_block->attr.module_procedure) 3546 gfc_current_ns->has_import_set = 1; 3547 break; 3548 3549 case ST_PROCEDURE: 3550 case ST_MODULE_PROC: /* The module procedure matcher makes 3551 sure the context is correct. */ 3552 accept_statement (st); 3553 gfc_free_namespace (gfc_current_ns); 3554 goto loop; 3555 3556 case ST_END_INTERFACE: 3557 gfc_free_namespace (gfc_current_ns); 3558 gfc_current_ns = current_interface.ns; 3559 goto done; 3560 3561 default: 3562 gfc_error ("Unexpected %s statement in INTERFACE block at %C", 3563 gfc_ascii_statement (st)); 3564 reject_statement (); 3565 gfc_free_namespace (gfc_current_ns); 3566 goto loop; 3567 } 3568 3569 3570 /* Make sure that the generic name has the right attribute. */ 3571 if (current_interface.type == INTERFACE_GENERIC 3572 && current_state == COMP_NONE) 3573 { 3574 if (new_state == COMP_FUNCTION && sym) 3575 gfc_add_function (&sym->attr, sym->name, NULL); 3576 else if (new_state == COMP_SUBROUTINE && sym) 3577 gfc_add_subroutine (&sym->attr, sym->name, NULL); 3578 3579 current_state = new_state; 3580 } 3581 3582 if (current_interface.type == INTERFACE_ABSTRACT) 3583 { 3584 gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus); 3585 if (gfc_is_intrinsic_typename (gfc_new_block->name)) 3586 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C " 3587 "cannot be the same as an intrinsic type", 3588 gfc_new_block->name); 3589 } 3590 3591 push_state (&s2, new_state, gfc_new_block); 3592 accept_statement (st); 3593 prog_unit = gfc_new_block; 3594 prog_unit->formal_ns = gfc_current_ns; 3595 if (prog_unit == prog_unit->formal_ns->proc_name 3596 && prog_unit->ns != prog_unit->formal_ns) 3597 prog_unit->refs++; 3598 3599 decl: 3600 /* Read data declaration statements. */ 3601 st = parse_spec (ST_NONE); 3602 in_specification_block = true; 3603 3604 /* Since the interface block does not permit an IMPLICIT statement, 3605 the default type for the function or the result must be taken 3606 from the formal namespace. */ 3607 if (new_state == COMP_FUNCTION) 3608 { 3609 if (prog_unit->result == prog_unit 3610 && prog_unit->ts.type == BT_UNKNOWN) 3611 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns); 3612 else if (prog_unit->result != prog_unit 3613 && prog_unit->result->ts.type == BT_UNKNOWN) 3614 gfc_set_default_type (prog_unit->result, 1, 3615 prog_unit->formal_ns); 3616 } 3617 3618 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION) 3619 { 3620 gfc_error ("Unexpected %s statement at %C in INTERFACE body", 3621 gfc_ascii_statement (st)); 3622 reject_statement (); 3623 goto decl; 3624 } 3625 3626 /* Add EXTERNAL attribute to function or subroutine. */ 3627 if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy) 3628 gfc_add_external (&prog_unit->attr, &gfc_current_locus); 3629 3630 current_interface = save; 3631 gfc_add_interface (prog_unit); 3632 pop_state (); 3633 3634 if (current_interface.ns 3635 && current_interface.ns->proc_name 3636 && strcmp (current_interface.ns->proc_name->name, 3637 prog_unit->name) == 0) 3638 gfc_error ("INTERFACE procedure %qs at %L has the same name as the " 3639 "enclosing procedure", prog_unit->name, 3640 ¤t_interface.ns->proc_name->declared_at); 3641 3642 goto loop; 3643 3644 done: 3645 pop_state (); 3646 } 3647 3648 3649 /* Associate function characteristics by going back to the function 3650 declaration and rematching the prefix. */ 3651 3652 static match 3653 match_deferred_characteristics (gfc_typespec * ts) 3654 { 3655 locus loc; 3656 match m = MATCH_ERROR; 3657 char name[GFC_MAX_SYMBOL_LEN + 1]; 3658 3659 loc = gfc_current_locus; 3660 3661 gfc_current_locus = gfc_current_block ()->declared_at; 3662 3663 gfc_clear_error (); 3664 gfc_buffer_error (true); 3665 m = gfc_match_prefix (ts); 3666 gfc_buffer_error (false); 3667 3668 if (ts->type == BT_DERIVED) 3669 { 3670 ts->kind = 0; 3671 3672 if (!ts->u.derived) 3673 m = MATCH_ERROR; 3674 } 3675 3676 /* Only permit one go at the characteristic association. */ 3677 if (ts->kind == -1) 3678 ts->kind = 0; 3679 3680 /* Set the function locus correctly. If we have not found the 3681 function name, there is an error. */ 3682 if (m == MATCH_YES 3683 && gfc_match ("function% %n", name) == MATCH_YES 3684 && strcmp (name, gfc_current_block ()->name) == 0) 3685 { 3686 gfc_current_block ()->declared_at = gfc_current_locus; 3687 gfc_commit_symbols (); 3688 } 3689 else 3690 { 3691 gfc_error_check (); 3692 gfc_undo_symbols (); 3693 } 3694 3695 gfc_current_locus =loc; 3696 return m; 3697 } 3698 3699 3700 /* Check specification-expressions in the function result of the currently 3701 parsed block and ensure they are typed (give an IMPLICIT type if necessary). 3702 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the 3703 scope are not yet parsed so this has to be delayed up to parse_spec. */ 3704 3705 static void 3706 check_function_result_typed (void) 3707 { 3708 gfc_typespec ts; 3709 3710 gcc_assert (gfc_current_state () == COMP_FUNCTION); 3711 3712 if (!gfc_current_ns->proc_name->result) return; 3713 3714 ts = gfc_current_ns->proc_name->result->ts; 3715 3716 /* Check type-parameters, at the moment only CHARACTER lengths possible. */ 3717 /* TODO: Extend when KIND type parameters are implemented. */ 3718 if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length) 3719 gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true); 3720 } 3721 3722 3723 /* Parse a set of specification statements. Returns the statement 3724 that doesn't fit. */ 3725 3726 static gfc_statement 3727 parse_spec (gfc_statement st) 3728 { 3729 st_state ss; 3730 bool function_result_typed = false; 3731 bool bad_characteristic = false; 3732 gfc_typespec *ts; 3733 3734 in_specification_block = true; 3735 3736 verify_st_order (&ss, ST_NONE, false); 3737 if (st == ST_NONE) 3738 st = next_statement (); 3739 3740 /* If we are not inside a function or don't have a result specified so far, 3741 do nothing special about it. */ 3742 if (gfc_current_state () != COMP_FUNCTION) 3743 function_result_typed = true; 3744 else 3745 { 3746 gfc_symbol* proc = gfc_current_ns->proc_name; 3747 gcc_assert (proc); 3748 3749 if (proc->result->ts.type == BT_UNKNOWN) 3750 function_result_typed = true; 3751 } 3752 3753 loop: 3754 3755 /* If we're inside a BLOCK construct, some statements are disallowed. 3756 Check this here. Attribute declaration statements like INTENT, OPTIONAL 3757 or VALUE are also disallowed, but they don't have a particular ST_* 3758 key so we have to check for them individually in their matcher routine. */ 3759 if (gfc_current_state () == COMP_BLOCK) 3760 switch (st) 3761 { 3762 case ST_IMPLICIT: 3763 case ST_IMPLICIT_NONE: 3764 case ST_NAMELIST: 3765 case ST_COMMON: 3766 case ST_EQUIVALENCE: 3767 case ST_STATEMENT_FUNCTION: 3768 gfc_error ("%s statement is not allowed inside of BLOCK at %C", 3769 gfc_ascii_statement (st)); 3770 reject_statement (); 3771 break; 3772 3773 default: 3774 break; 3775 } 3776 else if (gfc_current_state () == COMP_BLOCK_DATA) 3777 /* Fortran 2008, C1116. */ 3778 switch (st) 3779 { 3780 case ST_ATTR_DECL: 3781 case ST_COMMON: 3782 case ST_DATA: 3783 case ST_DATA_DECL: 3784 case ST_DERIVED_DECL: 3785 case ST_END_BLOCK_DATA: 3786 case ST_EQUIVALENCE: 3787 case ST_IMPLICIT: 3788 case ST_IMPLICIT_NONE: 3789 case ST_OMP_THREADPRIVATE: 3790 case ST_PARAMETER: 3791 case ST_STRUCTURE_DECL: 3792 case ST_TYPE: 3793 case ST_USE: 3794 break; 3795 3796 case ST_NONE: 3797 break; 3798 3799 default: 3800 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C", 3801 gfc_ascii_statement (st)); 3802 reject_statement (); 3803 break; 3804 } 3805 3806 /* If we find a statement that cannot be followed by an IMPLICIT statement 3807 (and thus we can expect to see none any further), type the function result 3808 if it has not yet been typed. Be careful not to give the END statement 3809 to verify_st_order! */ 3810 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS) 3811 { 3812 bool verify_now = false; 3813 3814 if (st == ST_END_FUNCTION || st == ST_CONTAINS) 3815 verify_now = true; 3816 else 3817 { 3818 st_state dummyss; 3819 verify_st_order (&dummyss, ST_NONE, false); 3820 verify_st_order (&dummyss, st, false); 3821 3822 if (!verify_st_order (&dummyss, ST_IMPLICIT, true)) 3823 verify_now = true; 3824 } 3825 3826 if (verify_now) 3827 { 3828 check_function_result_typed (); 3829 function_result_typed = true; 3830 } 3831 } 3832 3833 switch (st) 3834 { 3835 case ST_NONE: 3836 unexpected_eof (); 3837 3838 case ST_IMPLICIT_NONE: 3839 case ST_IMPLICIT: 3840 if (!function_result_typed) 3841 { 3842 check_function_result_typed (); 3843 function_result_typed = true; 3844 } 3845 goto declSt; 3846 3847 case ST_FORMAT: 3848 case ST_ENTRY: 3849 case ST_DATA: /* Not allowed in interfaces */ 3850 if (gfc_current_state () == COMP_INTERFACE) 3851 break; 3852 3853 /* Fall through */ 3854 3855 case ST_USE: 3856 case ST_IMPORT: 3857 case ST_PARAMETER: 3858 case ST_PUBLIC: 3859 case ST_PRIVATE: 3860 case ST_STRUCTURE_DECL: 3861 case ST_DERIVED_DECL: 3862 case_decl: 3863 case_omp_decl: 3864 declSt: 3865 if (!verify_st_order (&ss, st, false)) 3866 { 3867 reject_statement (); 3868 st = next_statement (); 3869 goto loop; 3870 } 3871 3872 switch (st) 3873 { 3874 case ST_INTERFACE: 3875 parse_interface (); 3876 break; 3877 3878 case ST_STRUCTURE_DECL: 3879 parse_struct_map (ST_STRUCTURE_DECL); 3880 break; 3881 3882 case ST_DERIVED_DECL: 3883 parse_derived (); 3884 break; 3885 3886 case ST_PUBLIC: 3887 case ST_PRIVATE: 3888 if (gfc_current_state () != COMP_MODULE) 3889 { 3890 gfc_error ("%s statement must appear in a MODULE", 3891 gfc_ascii_statement (st)); 3892 reject_statement (); 3893 break; 3894 } 3895 3896 if (gfc_current_ns->default_access != ACCESS_UNKNOWN) 3897 { 3898 gfc_error ("%s statement at %C follows another accessibility " 3899 "specification", gfc_ascii_statement (st)); 3900 reject_statement (); 3901 break; 3902 } 3903 3904 gfc_current_ns->default_access = (st == ST_PUBLIC) 3905 ? ACCESS_PUBLIC : ACCESS_PRIVATE; 3906 3907 break; 3908 3909 case ST_STATEMENT_FUNCTION: 3910 if (gfc_current_state () == COMP_MODULE 3911 || gfc_current_state () == COMP_SUBMODULE) 3912 { 3913 unexpected_statement (st); 3914 break; 3915 } 3916 3917 default: 3918 break; 3919 } 3920 3921 accept_statement (st); 3922 st = next_statement (); 3923 goto loop; 3924 3925 case ST_ENUM: 3926 accept_statement (st); 3927 parse_enum(); 3928 st = next_statement (); 3929 goto loop; 3930 3931 case ST_GET_FCN_CHARACTERISTICS: 3932 /* This statement triggers the association of a function's result 3933 characteristics. */ 3934 ts = &gfc_current_block ()->result->ts; 3935 if (match_deferred_characteristics (ts) != MATCH_YES) 3936 bad_characteristic = true; 3937 3938 st = next_statement (); 3939 goto loop; 3940 3941 default: 3942 break; 3943 } 3944 3945 /* If match_deferred_characteristics failed, then there is an error. */ 3946 if (bad_characteristic) 3947 { 3948 ts = &gfc_current_block ()->result->ts; 3949 if (ts->type != BT_DERIVED) 3950 gfc_error ("Bad kind expression for function %qs at %L", 3951 gfc_current_block ()->name, 3952 &gfc_current_block ()->declared_at); 3953 else 3954 gfc_error ("The type for function %qs at %L is not accessible", 3955 gfc_current_block ()->name, 3956 &gfc_current_block ()->declared_at); 3957 3958 gfc_current_block ()->ts.kind = 0; 3959 /* Keep the derived type; if it's bad, it will be discovered later. */ 3960 if (!(ts->type == BT_DERIVED && ts->u.derived)) 3961 ts->type = BT_UNKNOWN; 3962 } 3963 3964 in_specification_block = false; 3965 3966 return st; 3967 } 3968 3969 3970 /* Parse a WHERE block, (not a simple WHERE statement). */ 3971 3972 static void 3973 parse_where_block (void) 3974 { 3975 int seen_empty_else; 3976 gfc_code *top, *d; 3977 gfc_state_data s; 3978 gfc_statement st; 3979 3980 accept_statement (ST_WHERE_BLOCK); 3981 top = gfc_state_stack->tail; 3982 3983 push_state (&s, COMP_WHERE, gfc_new_block); 3984 3985 d = add_statement (); 3986 d->expr1 = top->expr1; 3987 d->op = EXEC_WHERE; 3988 3989 top->expr1 = NULL; 3990 top->block = d; 3991 3992 seen_empty_else = 0; 3993 3994 do 3995 { 3996 st = next_statement (); 3997 switch (st) 3998 { 3999 case ST_NONE: 4000 unexpected_eof (); 4001 4002 case ST_WHERE_BLOCK: 4003 parse_where_block (); 4004 break; 4005 4006 case ST_ASSIGNMENT: 4007 case ST_WHERE: 4008 accept_statement (st); 4009 break; 4010 4011 case ST_ELSEWHERE: 4012 if (seen_empty_else) 4013 { 4014 gfc_error ("ELSEWHERE statement at %C follows previous " 4015 "unmasked ELSEWHERE"); 4016 reject_statement (); 4017 break; 4018 } 4019 4020 if (new_st.expr1 == NULL) 4021 seen_empty_else = 1; 4022 4023 d = new_level (gfc_state_stack->head); 4024 d->op = EXEC_WHERE; 4025 d->expr1 = new_st.expr1; 4026 4027 accept_statement (st); 4028 4029 break; 4030 4031 case ST_END_WHERE: 4032 accept_statement (st); 4033 break; 4034 4035 default: 4036 gfc_error ("Unexpected %s statement in WHERE block at %C", 4037 gfc_ascii_statement (st)); 4038 reject_statement (); 4039 break; 4040 } 4041 } 4042 while (st != ST_END_WHERE); 4043 4044 pop_state (); 4045 } 4046 4047 4048 /* Parse a FORALL block (not a simple FORALL statement). */ 4049 4050 static void 4051 parse_forall_block (void) 4052 { 4053 gfc_code *top, *d; 4054 gfc_state_data s; 4055 gfc_statement st; 4056 4057 accept_statement (ST_FORALL_BLOCK); 4058 top = gfc_state_stack->tail; 4059 4060 push_state (&s, COMP_FORALL, gfc_new_block); 4061 4062 d = add_statement (); 4063 d->op = EXEC_FORALL; 4064 top->block = d; 4065 4066 do 4067 { 4068 st = next_statement (); 4069 switch (st) 4070 { 4071 4072 case ST_ASSIGNMENT: 4073 case ST_POINTER_ASSIGNMENT: 4074 case ST_WHERE: 4075 case ST_FORALL: 4076 accept_statement (st); 4077 break; 4078 4079 case ST_WHERE_BLOCK: 4080 parse_where_block (); 4081 break; 4082 4083 case ST_FORALL_BLOCK: 4084 parse_forall_block (); 4085 break; 4086 4087 case ST_END_FORALL: 4088 accept_statement (st); 4089 break; 4090 4091 case ST_NONE: 4092 unexpected_eof (); 4093 4094 default: 4095 gfc_error ("Unexpected %s statement in FORALL block at %C", 4096 gfc_ascii_statement (st)); 4097 4098 reject_statement (); 4099 break; 4100 } 4101 } 4102 while (st != ST_END_FORALL); 4103 4104 pop_state (); 4105 } 4106 4107 4108 static gfc_statement parse_executable (gfc_statement); 4109 4110 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */ 4111 4112 static void 4113 parse_if_block (void) 4114 { 4115 gfc_code *top, *d; 4116 gfc_statement st; 4117 locus else_locus; 4118 gfc_state_data s; 4119 int seen_else; 4120 4121 seen_else = 0; 4122 accept_statement (ST_IF_BLOCK); 4123 4124 top = gfc_state_stack->tail; 4125 push_state (&s, COMP_IF, gfc_new_block); 4126 4127 new_st.op = EXEC_IF; 4128 d = add_statement (); 4129 4130 d->expr1 = top->expr1; 4131 top->expr1 = NULL; 4132 top->block = d; 4133 4134 do 4135 { 4136 st = parse_executable (ST_NONE); 4137 4138 switch (st) 4139 { 4140 case ST_NONE: 4141 unexpected_eof (); 4142 4143 case ST_ELSEIF: 4144 if (seen_else) 4145 { 4146 gfc_error ("ELSE IF statement at %C cannot follow ELSE " 4147 "statement at %L", &else_locus); 4148 4149 reject_statement (); 4150 break; 4151 } 4152 4153 d = new_level (gfc_state_stack->head); 4154 d->op = EXEC_IF; 4155 d->expr1 = new_st.expr1; 4156 4157 accept_statement (st); 4158 4159 break; 4160 4161 case ST_ELSE: 4162 if (seen_else) 4163 { 4164 gfc_error ("Duplicate ELSE statements at %L and %C", 4165 &else_locus); 4166 reject_statement (); 4167 break; 4168 } 4169 4170 seen_else = 1; 4171 else_locus = gfc_current_locus; 4172 4173 d = new_level (gfc_state_stack->head); 4174 d->op = EXEC_IF; 4175 4176 accept_statement (st); 4177 4178 break; 4179 4180 case ST_ENDIF: 4181 break; 4182 4183 default: 4184 unexpected_statement (st); 4185 break; 4186 } 4187 } 4188 while (st != ST_ENDIF); 4189 4190 pop_state (); 4191 accept_statement (st); 4192 } 4193 4194 4195 /* Parse a SELECT block. */ 4196 4197 static void 4198 parse_select_block (void) 4199 { 4200 gfc_statement st; 4201 gfc_code *cp; 4202 gfc_state_data s; 4203 4204 accept_statement (ST_SELECT_CASE); 4205 4206 cp = gfc_state_stack->tail; 4207 push_state (&s, COMP_SELECT, gfc_new_block); 4208 4209 /* Make sure that the next statement is a CASE or END SELECT. */ 4210 for (;;) 4211 { 4212 st = next_statement (); 4213 if (st == ST_NONE) 4214 unexpected_eof (); 4215 if (st == ST_END_SELECT) 4216 { 4217 /* Empty SELECT CASE is OK. */ 4218 accept_statement (st); 4219 pop_state (); 4220 return; 4221 } 4222 if (st == ST_CASE) 4223 break; 4224 4225 gfc_error ("Expected a CASE or END SELECT statement following SELECT " 4226 "CASE at %C"); 4227 4228 reject_statement (); 4229 } 4230 4231 /* At this point, we've got a nonempty select block. */ 4232 cp = new_level (cp); 4233 *cp = new_st; 4234 4235 accept_statement (st); 4236 4237 do 4238 { 4239 st = parse_executable (ST_NONE); 4240 switch (st) 4241 { 4242 case ST_NONE: 4243 unexpected_eof (); 4244 4245 case ST_CASE: 4246 cp = new_level (gfc_state_stack->head); 4247 *cp = new_st; 4248 gfc_clear_new_st (); 4249 4250 accept_statement (st); 4251 /* Fall through */ 4252 4253 case ST_END_SELECT: 4254 break; 4255 4256 /* Can't have an executable statement because of 4257 parse_executable(). */ 4258 default: 4259 unexpected_statement (st); 4260 break; 4261 } 4262 } 4263 while (st != ST_END_SELECT); 4264 4265 pop_state (); 4266 accept_statement (st); 4267 } 4268 4269 4270 /* Pop the current selector from the SELECT TYPE stack. */ 4271 4272 static void 4273 select_type_pop (void) 4274 { 4275 gfc_select_type_stack *old = select_type_stack; 4276 select_type_stack = old->prev; 4277 free (old); 4278 } 4279 4280 4281 /* Parse a SELECT TYPE construct (F03:R821). */ 4282 4283 static void 4284 parse_select_type_block (void) 4285 { 4286 gfc_statement st; 4287 gfc_code *cp; 4288 gfc_state_data s; 4289 4290 gfc_current_ns = new_st.ext.block.ns; 4291 accept_statement (ST_SELECT_TYPE); 4292 4293 cp = gfc_state_stack->tail; 4294 push_state (&s, COMP_SELECT_TYPE, gfc_new_block); 4295 4296 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT 4297 or END SELECT. */ 4298 for (;;) 4299 { 4300 st = next_statement (); 4301 if (st == ST_NONE) 4302 unexpected_eof (); 4303 if (st == ST_END_SELECT) 4304 /* Empty SELECT CASE is OK. */ 4305 goto done; 4306 if (st == ST_TYPE_IS || st == ST_CLASS_IS) 4307 break; 4308 4309 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement " 4310 "following SELECT TYPE at %C"); 4311 4312 reject_statement (); 4313 } 4314 4315 /* At this point, we've got a nonempty select block. */ 4316 cp = new_level (cp); 4317 *cp = new_st; 4318 4319 accept_statement (st); 4320 4321 do 4322 { 4323 st = parse_executable (ST_NONE); 4324 switch (st) 4325 { 4326 case ST_NONE: 4327 unexpected_eof (); 4328 4329 case ST_TYPE_IS: 4330 case ST_CLASS_IS: 4331 cp = new_level (gfc_state_stack->head); 4332 *cp = new_st; 4333 gfc_clear_new_st (); 4334 4335 accept_statement (st); 4336 /* Fall through */ 4337 4338 case ST_END_SELECT: 4339 break; 4340 4341 /* Can't have an executable statement because of 4342 parse_executable(). */ 4343 default: 4344 unexpected_statement (st); 4345 break; 4346 } 4347 } 4348 while (st != ST_END_SELECT); 4349 4350 done: 4351 pop_state (); 4352 accept_statement (st); 4353 gfc_current_ns = gfc_current_ns->parent; 4354 select_type_pop (); 4355 } 4356 4357 4358 /* Parse a SELECT RANK construct. */ 4359 4360 static void 4361 parse_select_rank_block (void) 4362 { 4363 gfc_statement st; 4364 gfc_code *cp; 4365 gfc_state_data s; 4366 4367 gfc_current_ns = new_st.ext.block.ns; 4368 accept_statement (ST_SELECT_RANK); 4369 4370 cp = gfc_state_stack->tail; 4371 push_state (&s, COMP_SELECT_RANK, gfc_new_block); 4372 4373 /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */ 4374 for (;;) 4375 { 4376 st = next_statement (); 4377 if (st == ST_NONE) 4378 unexpected_eof (); 4379 if (st == ST_END_SELECT) 4380 /* Empty SELECT CASE is OK. */ 4381 goto done; 4382 if (st == ST_RANK) 4383 break; 4384 4385 gfc_error ("Expected RANK or RANK DEFAULT " 4386 "following SELECT RANK at %C"); 4387 4388 reject_statement (); 4389 } 4390 4391 /* At this point, we've got a nonempty select block. */ 4392 cp = new_level (cp); 4393 *cp = new_st; 4394 4395 accept_statement (st); 4396 4397 do 4398 { 4399 st = parse_executable (ST_NONE); 4400 switch (st) 4401 { 4402 case ST_NONE: 4403 unexpected_eof (); 4404 4405 case ST_RANK: 4406 cp = new_level (gfc_state_stack->head); 4407 *cp = new_st; 4408 gfc_clear_new_st (); 4409 4410 accept_statement (st); 4411 /* Fall through */ 4412 4413 case ST_END_SELECT: 4414 break; 4415 4416 /* Can't have an executable statement because of 4417 parse_executable(). */ 4418 default: 4419 unexpected_statement (st); 4420 break; 4421 } 4422 } 4423 while (st != ST_END_SELECT); 4424 4425 done: 4426 pop_state (); 4427 accept_statement (st); 4428 gfc_current_ns = gfc_current_ns->parent; 4429 select_type_pop (); 4430 } 4431 4432 4433 /* Given a symbol, make sure it is not an iteration variable for a DO 4434 statement. This subroutine is called when the symbol is seen in a 4435 context that causes it to become redefined. If the symbol is an 4436 iterator, we generate an error message and return nonzero. */ 4437 4438 int 4439 gfc_check_do_variable (gfc_symtree *st) 4440 { 4441 gfc_state_data *s; 4442 4443 if (!st) 4444 return 0; 4445 4446 for (s=gfc_state_stack; s; s = s->previous) 4447 if (s->do_variable == st) 4448 { 4449 gfc_error_now ("Variable %qs at %C cannot be redefined inside " 4450 "loop beginning at %L", st->name, &s->head->loc); 4451 return 1; 4452 } 4453 4454 return 0; 4455 } 4456 4457 4458 /* Checks to see if the current statement label closes an enddo. 4459 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues 4460 an error) if it incorrectly closes an ENDDO. */ 4461 4462 static int 4463 check_do_closure (void) 4464 { 4465 gfc_state_data *p; 4466 4467 if (gfc_statement_label == NULL) 4468 return 0; 4469 4470 for (p = gfc_state_stack; p; p = p->previous) 4471 if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) 4472 break; 4473 4474 if (p == NULL) 4475 return 0; /* No loops to close */ 4476 4477 if (p->ext.end_do_label == gfc_statement_label) 4478 { 4479 if (p == gfc_state_stack) 4480 return 1; 4481 4482 gfc_error ("End of nonblock DO statement at %C is within another block"); 4483 return 2; 4484 } 4485 4486 /* At this point, the label doesn't terminate the innermost loop. 4487 Make sure it doesn't terminate another one. */ 4488 for (; p; p = p->previous) 4489 if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) 4490 && p->ext.end_do_label == gfc_statement_label) 4491 { 4492 gfc_error ("End of nonblock DO statement at %C is interwoven " 4493 "with another DO loop"); 4494 return 2; 4495 } 4496 4497 return 0; 4498 } 4499 4500 4501 /* Parse a series of contained program units. */ 4502 4503 static void parse_progunit (gfc_statement); 4504 4505 4506 /* Parse a CRITICAL block. */ 4507 4508 static void 4509 parse_critical_block (void) 4510 { 4511 gfc_code *top, *d; 4512 gfc_state_data s, *sd; 4513 gfc_statement st; 4514 4515 for (sd = gfc_state_stack; sd; sd = sd->previous) 4516 if (sd->state == COMP_OMP_STRUCTURED_BLOCK) 4517 gfc_error_now (is_oacc (sd) 4518 ? G_("CRITICAL block inside of OpenACC region at %C") 4519 : G_("CRITICAL block inside of OpenMP region at %C")); 4520 4521 s.ext.end_do_label = new_st.label1; 4522 4523 accept_statement (ST_CRITICAL); 4524 top = gfc_state_stack->tail; 4525 4526 push_state (&s, COMP_CRITICAL, gfc_new_block); 4527 4528 d = add_statement (); 4529 d->op = EXEC_CRITICAL; 4530 top->block = d; 4531 4532 do 4533 { 4534 st = parse_executable (ST_NONE); 4535 4536 switch (st) 4537 { 4538 case ST_NONE: 4539 unexpected_eof (); 4540 break; 4541 4542 case ST_END_CRITICAL: 4543 if (s.ext.end_do_label != NULL 4544 && s.ext.end_do_label != gfc_statement_label) 4545 gfc_error_now ("Statement label in END CRITICAL at %C does not " 4546 "match CRITICAL label"); 4547 4548 if (gfc_statement_label != NULL) 4549 { 4550 new_st.op = EXEC_NOP; 4551 add_statement (); 4552 } 4553 break; 4554 4555 default: 4556 unexpected_statement (st); 4557 break; 4558 } 4559 } 4560 while (st != ST_END_CRITICAL); 4561 4562 pop_state (); 4563 accept_statement (st); 4564 } 4565 4566 4567 /* Set up the local namespace for a BLOCK construct. */ 4568 4569 gfc_namespace* 4570 gfc_build_block_ns (gfc_namespace *parent_ns) 4571 { 4572 gfc_namespace* my_ns; 4573 static int numblock = 1; 4574 4575 my_ns = gfc_get_namespace (parent_ns, 1); 4576 my_ns->construct_entities = 1; 4577 4578 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct 4579 code generation (so it must not be NULL). 4580 We set its recursive argument if our container procedure is recursive, so 4581 that local variables are accordingly placed on the stack when it 4582 will be necessary. */ 4583 if (gfc_new_block) 4584 my_ns->proc_name = gfc_new_block; 4585 else 4586 { 4587 bool t; 4588 char buffer[20]; /* Enough to hold "block@2147483648\n". */ 4589 4590 snprintf(buffer, sizeof(buffer), "block@%d", numblock++); 4591 gfc_get_symbol (buffer, my_ns, &my_ns->proc_name); 4592 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL, 4593 my_ns->proc_name->name, NULL); 4594 gcc_assert (t); 4595 gfc_commit_symbol (my_ns->proc_name); 4596 } 4597 4598 if (parent_ns->proc_name) 4599 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive; 4600 4601 return my_ns; 4602 } 4603 4604 4605 /* Parse a BLOCK construct. */ 4606 4607 static void 4608 parse_block_construct (void) 4609 { 4610 gfc_namespace* my_ns; 4611 gfc_namespace* my_parent; 4612 gfc_state_data s; 4613 4614 gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C"); 4615 4616 my_ns = gfc_build_block_ns (gfc_current_ns); 4617 4618 new_st.op = EXEC_BLOCK; 4619 new_st.ext.block.ns = my_ns; 4620 new_st.ext.block.assoc = NULL; 4621 accept_statement (ST_BLOCK); 4622 4623 push_state (&s, COMP_BLOCK, my_ns->proc_name); 4624 gfc_current_ns = my_ns; 4625 my_parent = my_ns->parent; 4626 4627 parse_progunit (ST_NONE); 4628 4629 /* Don't depend on the value of gfc_current_ns; it might have been 4630 reset if the block had errors and was cleaned up. */ 4631 gfc_current_ns = my_parent; 4632 4633 pop_state (); 4634 } 4635 4636 4637 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct 4638 behind the scenes with compiler-generated variables. */ 4639 4640 static void 4641 parse_associate (void) 4642 { 4643 gfc_namespace* my_ns; 4644 gfc_state_data s; 4645 gfc_statement st; 4646 gfc_association_list* a; 4647 4648 gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); 4649 4650 my_ns = gfc_build_block_ns (gfc_current_ns); 4651 4652 new_st.op = EXEC_BLOCK; 4653 new_st.ext.block.ns = my_ns; 4654 gcc_assert (new_st.ext.block.assoc); 4655 4656 /* Add all associate-names as BLOCK variables. Creating them is enough 4657 for now, they'll get their values during trans-* phase. */ 4658 gfc_current_ns = my_ns; 4659 for (a = new_st.ext.block.assoc; a; a = a->next) 4660 { 4661 gfc_symbol* sym; 4662 gfc_ref *ref; 4663 gfc_array_ref *array_ref; 4664 4665 if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) 4666 gcc_unreachable (); 4667 4668 sym = a->st->n.sym; 4669 sym->attr.flavor = FL_VARIABLE; 4670 sym->assoc = a; 4671 sym->declared_at = a->where; 4672 gfc_set_sym_referenced (sym); 4673 4674 /* Initialize the typespec. It is not available in all cases, 4675 however, as it may only be set on the target during resolution. 4676 Still, sometimes it helps to have it right now -- especially 4677 for parsing component references on the associate-name 4678 in case of association to a derived-type. */ 4679 sym->ts = a->target->ts; 4680 4681 /* Don’t share the character length information between associate 4682 variable and target if the length is not a compile-time constant, 4683 as we don’t want to touch some other character length variable when 4684 we try to initialize the associate variable’s character length 4685 variable. 4686 We do it here rather than later so that expressions referencing the 4687 associate variable will automatically have the correctly setup length 4688 information. If we did it at resolution stage the expressions would 4689 use the original length information, and the variable a new different 4690 one, but only the latter one would be correctly initialized at 4691 translation stage, and the former one would need some additional setup 4692 there. */ 4693 if (sym->ts.type == BT_CHARACTER 4694 && sym->ts.u.cl 4695 && !(sym->ts.u.cl->length 4696 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) 4697 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 4698 4699 /* Check if the target expression is array valued. This cannot always 4700 be done by looking at target.rank, because that might not have been 4701 set yet. Therefore traverse the chain of refs, looking for the last 4702 array ref and evaluate that. */ 4703 array_ref = NULL; 4704 for (ref = a->target->ref; ref; ref = ref->next) 4705 if (ref->type == REF_ARRAY) 4706 array_ref = &ref->u.ar; 4707 if (array_ref || a->target->rank) 4708 { 4709 gfc_array_spec *as; 4710 int dim, rank = 0; 4711 if (array_ref) 4712 { 4713 a->rankguessed = 1; 4714 /* Count the dimension, that have a non-scalar extend. */ 4715 for (dim = 0; dim < array_ref->dimen; ++dim) 4716 if (array_ref->dimen_type[dim] != DIMEN_ELEMENT 4717 && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN 4718 && array_ref->end[dim] == NULL 4719 && array_ref->start[dim] != NULL)) 4720 ++rank; 4721 } 4722 else 4723 rank = a->target->rank; 4724 /* When the rank is greater than zero then sym will be an array. */ 4725 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) 4726 { 4727 if ((!CLASS_DATA (sym)->as && rank != 0) 4728 || (CLASS_DATA (sym)->as 4729 && CLASS_DATA (sym)->as->rank != rank)) 4730 { 4731 /* Don't just (re-)set the attr and as in the sym.ts, 4732 because this modifies the target's attr and as. Copy the 4733 data and do a build_class_symbol. */ 4734 symbol_attribute attr = CLASS_DATA (a->target)->attr; 4735 int corank = gfc_get_corank (a->target); 4736 gfc_typespec type; 4737 4738 if (rank || corank) 4739 { 4740 as = gfc_get_array_spec (); 4741 as->type = AS_DEFERRED; 4742 as->rank = rank; 4743 as->corank = corank; 4744 attr.dimension = rank ? 1 : 0; 4745 attr.codimension = corank ? 1 : 0; 4746 } 4747 else 4748 { 4749 as = NULL; 4750 attr.dimension = attr.codimension = 0; 4751 } 4752 attr.class_ok = 0; 4753 type = CLASS_DATA (sym)->ts; 4754 if (!gfc_build_class_symbol (&type, 4755 &attr, &as)) 4756 gcc_unreachable (); 4757 sym->ts = type; 4758 sym->ts.type = BT_CLASS; 4759 sym->attr.class_ok = 1; 4760 } 4761 else 4762 sym->attr.class_ok = 1; 4763 } 4764 else if ((!sym->as && rank != 0) 4765 || (sym->as && sym->as->rank != rank)) 4766 { 4767 as = gfc_get_array_spec (); 4768 as->type = AS_DEFERRED; 4769 as->rank = rank; 4770 as->corank = gfc_get_corank (a->target); 4771 sym->as = as; 4772 sym->attr.dimension = 1; 4773 if (as->corank) 4774 sym->attr.codimension = 1; 4775 } 4776 } 4777 } 4778 4779 accept_statement (ST_ASSOCIATE); 4780 push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); 4781 4782 loop: 4783 st = parse_executable (ST_NONE); 4784 switch (st) 4785 { 4786 case ST_NONE: 4787 unexpected_eof (); 4788 4789 case_end: 4790 accept_statement (st); 4791 my_ns->code = gfc_state_stack->head; 4792 break; 4793 4794 default: 4795 unexpected_statement (st); 4796 goto loop; 4797 } 4798 4799 gfc_current_ns = gfc_current_ns->parent; 4800 pop_state (); 4801 } 4802 4803 4804 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are 4805 handled inside of parse_executable(), because they aren't really 4806 loop statements. */ 4807 4808 static void 4809 parse_do_block (void) 4810 { 4811 gfc_statement st; 4812 gfc_code *top; 4813 gfc_state_data s; 4814 gfc_symtree *stree; 4815 gfc_exec_op do_op; 4816 4817 do_op = new_st.op; 4818 s.ext.end_do_label = new_st.label1; 4819 4820 if (new_st.ext.iterator != NULL) 4821 { 4822 stree = new_st.ext.iterator->var->symtree; 4823 if (directive_unroll != -1) 4824 { 4825 new_st.ext.iterator->unroll = directive_unroll; 4826 directive_unroll = -1; 4827 } 4828 if (directive_ivdep) 4829 { 4830 new_st.ext.iterator->ivdep = directive_ivdep; 4831 directive_ivdep = false; 4832 } 4833 if (directive_vector) 4834 { 4835 new_st.ext.iterator->vector = directive_vector; 4836 directive_vector = false; 4837 } 4838 if (directive_novector) 4839 { 4840 new_st.ext.iterator->novector = directive_novector; 4841 directive_novector = false; 4842 } 4843 } 4844 else 4845 stree = NULL; 4846 4847 accept_statement (ST_DO); 4848 4849 top = gfc_state_stack->tail; 4850 push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO, 4851 gfc_new_block); 4852 4853 s.do_variable = stree; 4854 4855 top->block = new_level (top); 4856 top->block->op = EXEC_DO; 4857 4858 loop: 4859 st = parse_executable (ST_NONE); 4860 4861 switch (st) 4862 { 4863 case ST_NONE: 4864 unexpected_eof (); 4865 4866 case ST_ENDDO: 4867 if (s.ext.end_do_label != NULL 4868 && s.ext.end_do_label != gfc_statement_label) 4869 gfc_error_now ("Statement label in ENDDO at %C doesn't match " 4870 "DO label"); 4871 4872 if (gfc_statement_label != NULL) 4873 { 4874 new_st.op = EXEC_NOP; 4875 add_statement (); 4876 } 4877 break; 4878 4879 case ST_IMPLIED_ENDDO: 4880 /* If the do-stmt of this DO construct has a do-construct-name, 4881 the corresponding end-do must be an end-do-stmt (with a matching 4882 name, but in that case we must have seen ST_ENDDO first). 4883 We only complain about this in pedantic mode. */ 4884 if (gfc_current_block () != NULL) 4885 gfc_error_now ("Named block DO at %L requires matching ENDDO name", 4886 &gfc_current_block()->declared_at); 4887 4888 break; 4889 4890 default: 4891 unexpected_statement (st); 4892 goto loop; 4893 } 4894 4895 pop_state (); 4896 accept_statement (st); 4897 } 4898 4899 4900 /* Parse the statements of OpenMP do/parallel do. */ 4901 4902 static gfc_statement 4903 parse_omp_do (gfc_statement omp_st) 4904 { 4905 gfc_statement st; 4906 gfc_code *cp, *np; 4907 gfc_state_data s; 4908 4909 accept_statement (omp_st); 4910 4911 cp = gfc_state_stack->tail; 4912 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); 4913 np = new_level (cp); 4914 np->op = cp->op; 4915 np->block = NULL; 4916 4917 for (;;) 4918 { 4919 st = next_statement (); 4920 if (st == ST_NONE) 4921 unexpected_eof (); 4922 else if (st == ST_DO) 4923 break; 4924 else 4925 unexpected_statement (st); 4926 } 4927 4928 parse_do_block (); 4929 if (gfc_statement_label != NULL 4930 && gfc_state_stack->previous != NULL 4931 && gfc_state_stack->previous->state == COMP_DO 4932 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) 4933 { 4934 /* In 4935 DO 100 I=1,10 4936 !$OMP DO 4937 DO J=1,10 4938 ... 4939 100 CONTINUE 4940 there should be no !$OMP END DO. */ 4941 pop_state (); 4942 return ST_IMPLIED_ENDDO; 4943 } 4944 4945 check_do_closure (); 4946 pop_state (); 4947 4948 st = next_statement (); 4949 gfc_statement omp_end_st = ST_OMP_END_DO; 4950 switch (omp_st) 4951 { 4952 case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break; 4953 case ST_OMP_DISTRIBUTE_PARALLEL_DO: 4954 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO; 4955 break; 4956 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 4957 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; 4958 break; 4959 case ST_OMP_DISTRIBUTE_SIMD: 4960 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD; 4961 break; 4962 case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break; 4963 case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break; 4964 case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break; 4965 case ST_OMP_PARALLEL_DO_SIMD: 4966 omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD; 4967 break; 4968 case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break; 4969 case ST_OMP_TARGET_PARALLEL_DO: 4970 omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO; 4971 break; 4972 case ST_OMP_TARGET_PARALLEL_DO_SIMD: 4973 omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD; 4974 break; 4975 case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break; 4976 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: 4977 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; 4978 break; 4979 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 4980 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; 4981 break; 4982 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4983 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; 4984 break; 4985 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 4986 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; 4987 break; 4988 case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break; 4989 case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break; 4990 case ST_OMP_TEAMS_DISTRIBUTE: 4991 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; 4992 break; 4993 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 4994 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; 4995 break; 4996 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 4997 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; 4998 break; 4999 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: 5000 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; 5001 break; 5002 default: gcc_unreachable (); 5003 } 5004 if (st == omp_end_st) 5005 { 5006 if (new_st.op == EXEC_OMP_END_NOWAIT) 5007 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; 5008 else 5009 gcc_assert (new_st.op == EXEC_NOP); 5010 gfc_clear_new_st (); 5011 gfc_commit_symbols (); 5012 gfc_warning_check (); 5013 st = next_statement (); 5014 } 5015 return st; 5016 } 5017 5018 5019 /* Parse the statements of OpenMP atomic directive. */ 5020 5021 static gfc_statement 5022 parse_omp_oacc_atomic (bool omp_p) 5023 { 5024 gfc_statement st, st_atomic, st_end_atomic; 5025 gfc_code *cp, *np; 5026 gfc_state_data s; 5027 int count; 5028 5029 if (omp_p) 5030 { 5031 st_atomic = ST_OMP_ATOMIC; 5032 st_end_atomic = ST_OMP_END_ATOMIC; 5033 } 5034 else 5035 { 5036 st_atomic = ST_OACC_ATOMIC; 5037 st_end_atomic = ST_OACC_END_ATOMIC; 5038 } 5039 accept_statement (st_atomic); 5040 5041 cp = gfc_state_stack->tail; 5042 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); 5043 np = new_level (cp); 5044 np->op = cp->op; 5045 np->block = NULL; 5046 np->ext.omp_atomic = cp->ext.omp_atomic; 5047 count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) 5048 == GFC_OMP_ATOMIC_CAPTURE); 5049 5050 while (count) 5051 { 5052 st = next_statement (); 5053 if (st == ST_NONE) 5054 unexpected_eof (); 5055 else if (st == ST_ASSIGNMENT) 5056 { 5057 accept_statement (st); 5058 count--; 5059 } 5060 else 5061 unexpected_statement (st); 5062 } 5063 5064 pop_state (); 5065 5066 st = next_statement (); 5067 if (st == st_end_atomic) 5068 { 5069 gfc_clear_new_st (); 5070 gfc_commit_symbols (); 5071 gfc_warning_check (); 5072 st = next_statement (); 5073 } 5074 else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) 5075 == GFC_OMP_ATOMIC_CAPTURE) 5076 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C"); 5077 return st; 5078 } 5079 5080 5081 /* Parse the statements of an OpenACC structured block. */ 5082 5083 static void 5084 parse_oacc_structured_block (gfc_statement acc_st) 5085 { 5086 gfc_statement st, acc_end_st; 5087 gfc_code *cp, *np; 5088 gfc_state_data s, *sd; 5089 5090 for (sd = gfc_state_stack; sd; sd = sd->previous) 5091 if (sd->state == COMP_CRITICAL) 5092 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C"); 5093 5094 accept_statement (acc_st); 5095 5096 cp = gfc_state_stack->tail; 5097 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); 5098 np = new_level (cp); 5099 np->op = cp->op; 5100 np->block = NULL; 5101 switch (acc_st) 5102 { 5103 case ST_OACC_PARALLEL: 5104 acc_end_st = ST_OACC_END_PARALLEL; 5105 break; 5106 case ST_OACC_KERNELS: 5107 acc_end_st = ST_OACC_END_KERNELS; 5108 break; 5109 case ST_OACC_SERIAL: 5110 acc_end_st = ST_OACC_END_SERIAL; 5111 break; 5112 case ST_OACC_DATA: 5113 acc_end_st = ST_OACC_END_DATA; 5114 break; 5115 case ST_OACC_HOST_DATA: 5116 acc_end_st = ST_OACC_END_HOST_DATA; 5117 break; 5118 default: 5119 gcc_unreachable (); 5120 } 5121 5122 do 5123 { 5124 st = parse_executable (ST_NONE); 5125 if (st == ST_NONE) 5126 unexpected_eof (); 5127 else if (st != acc_end_st) 5128 { 5129 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st)); 5130 reject_statement (); 5131 } 5132 } 5133 while (st != acc_end_st); 5134 5135 gcc_assert (new_st.op == EXEC_NOP); 5136 5137 gfc_clear_new_st (); 5138 gfc_commit_symbols (); 5139 gfc_warning_check (); 5140 pop_state (); 5141 } 5142 5143 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */ 5144 5145 static gfc_statement 5146 parse_oacc_loop (gfc_statement acc_st) 5147 { 5148 gfc_statement st; 5149 gfc_code *cp, *np; 5150 gfc_state_data s, *sd; 5151 5152 for (sd = gfc_state_stack; sd; sd = sd->previous) 5153 if (sd->state == COMP_CRITICAL) 5154 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C"); 5155 5156 accept_statement (acc_st); 5157 5158 cp = gfc_state_stack->tail; 5159 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); 5160 np = new_level (cp); 5161 np->op = cp->op; 5162 np->block = NULL; 5163 5164 for (;;) 5165 { 5166 st = next_statement (); 5167 if (st == ST_NONE) 5168 unexpected_eof (); 5169 else if (st == ST_DO) 5170 break; 5171 else 5172 { 5173 gfc_error ("Expected DO loop at %C"); 5174 reject_statement (); 5175 } 5176 } 5177 5178 parse_do_block (); 5179 if (gfc_statement_label != NULL 5180 && gfc_state_stack->previous != NULL 5181 && gfc_state_stack->previous->state == COMP_DO 5182 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) 5183 { 5184 pop_state (); 5185 return ST_IMPLIED_ENDDO; 5186 } 5187 5188 check_do_closure (); 5189 pop_state (); 5190 5191 st = next_statement (); 5192 if (st == ST_OACC_END_LOOP) 5193 gfc_warning (0, "Redundant !$ACC END LOOP at %C"); 5194 if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) || 5195 (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) || 5196 (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) || 5197 (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP)) 5198 { 5199 gcc_assert (new_st.op == EXEC_NOP); 5200 gfc_clear_new_st (); 5201 gfc_commit_symbols (); 5202 gfc_warning_check (); 5203 st = next_statement (); 5204 } 5205 return st; 5206 } 5207 5208 5209 /* Parse the statements of an OpenMP structured block. */ 5210 5211 static void 5212 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) 5213 { 5214 gfc_statement st, omp_end_st; 5215 gfc_code *cp, *np; 5216 gfc_state_data s; 5217 5218 accept_statement (omp_st); 5219 5220 cp = gfc_state_stack->tail; 5221 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); 5222 np = new_level (cp); 5223 np->op = cp->op; 5224 np->block = NULL; 5225 5226 switch (omp_st) 5227 { 5228 case ST_OMP_PARALLEL: 5229 omp_end_st = ST_OMP_END_PARALLEL; 5230 break; 5231 case ST_OMP_PARALLEL_SECTIONS: 5232 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; 5233 break; 5234 case ST_OMP_SECTIONS: 5235 omp_end_st = ST_OMP_END_SECTIONS; 5236 break; 5237 case ST_OMP_ORDERED: 5238 omp_end_st = ST_OMP_END_ORDERED; 5239 break; 5240 case ST_OMP_CRITICAL: 5241 omp_end_st = ST_OMP_END_CRITICAL; 5242 break; 5243 case ST_OMP_MASTER: 5244 omp_end_st = ST_OMP_END_MASTER; 5245 break; 5246 case ST_OMP_SINGLE: 5247 omp_end_st = ST_OMP_END_SINGLE; 5248 break; 5249 case ST_OMP_TARGET: 5250 omp_end_st = ST_OMP_END_TARGET; 5251 break; 5252 case ST_OMP_TARGET_DATA: 5253 omp_end_st = ST_OMP_END_TARGET_DATA; 5254 break; 5255 case ST_OMP_TARGET_PARALLEL: 5256 omp_end_st = ST_OMP_END_TARGET_PARALLEL; 5257 break; 5258 case ST_OMP_TARGET_TEAMS: 5259 omp_end_st = ST_OMP_END_TARGET_TEAMS; 5260 break; 5261 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: 5262 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; 5263 break; 5264 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 5265 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; 5266 break; 5267 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5268 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; 5269 break; 5270 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 5271 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; 5272 break; 5273 case ST_OMP_TASK: 5274 omp_end_st = ST_OMP_END_TASK; 5275 break; 5276 case ST_OMP_TASKGROUP: 5277 omp_end_st = ST_OMP_END_TASKGROUP; 5278 break; 5279 case ST_OMP_TEAMS: 5280 omp_end_st = ST_OMP_END_TEAMS; 5281 break; 5282 case ST_OMP_TEAMS_DISTRIBUTE: 5283 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; 5284 break; 5285 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 5286 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; 5287 break; 5288 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5289 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; 5290 break; 5291 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: 5292 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; 5293 break; 5294 case ST_OMP_DISTRIBUTE: 5295 omp_end_st = ST_OMP_END_DISTRIBUTE; 5296 break; 5297 case ST_OMP_DISTRIBUTE_PARALLEL_DO: 5298 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO; 5299 break; 5300 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 5301 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; 5302 break; 5303 case ST_OMP_DISTRIBUTE_SIMD: 5304 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD; 5305 break; 5306 case ST_OMP_WORKSHARE: 5307 omp_end_st = ST_OMP_END_WORKSHARE; 5308 break; 5309 case ST_OMP_PARALLEL_WORKSHARE: 5310 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; 5311 break; 5312 default: 5313 gcc_unreachable (); 5314 } 5315 5316 do 5317 { 5318 if (workshare_stmts_only) 5319 { 5320 /* Inside of !$omp workshare, only 5321 scalar assignments 5322 array assignments 5323 where statements and constructs 5324 forall statements and constructs 5325 !$omp atomic 5326 !$omp critical 5327 !$omp parallel 5328 are allowed. For !$omp critical these 5329 restrictions apply recursively. */ 5330 bool cycle = true; 5331 5332 st = next_statement (); 5333 for (;;) 5334 { 5335 switch (st) 5336 { 5337 case ST_NONE: 5338 unexpected_eof (); 5339 5340 case ST_ASSIGNMENT: 5341 case ST_WHERE: 5342 case ST_FORALL: 5343 accept_statement (st); 5344 break; 5345 5346 case ST_WHERE_BLOCK: 5347 parse_where_block (); 5348 break; 5349 5350 case ST_FORALL_BLOCK: 5351 parse_forall_block (); 5352 break; 5353 5354 case ST_OMP_PARALLEL: 5355 case ST_OMP_PARALLEL_SECTIONS: 5356 parse_omp_structured_block (st, false); 5357 break; 5358 5359 case ST_OMP_PARALLEL_WORKSHARE: 5360 case ST_OMP_CRITICAL: 5361 parse_omp_structured_block (st, true); 5362 break; 5363 5364 case ST_OMP_PARALLEL_DO: 5365 case ST_OMP_PARALLEL_DO_SIMD: 5366 st = parse_omp_do (st); 5367 continue; 5368 5369 case ST_OMP_ATOMIC: 5370 st = parse_omp_oacc_atomic (true); 5371 continue; 5372 5373 default: 5374 cycle = false; 5375 break; 5376 } 5377 5378 if (!cycle) 5379 break; 5380 5381 st = next_statement (); 5382 } 5383 } 5384 else 5385 st = parse_executable (ST_NONE); 5386 if (st == ST_NONE) 5387 unexpected_eof (); 5388 else if (st == ST_OMP_SECTION 5389 && (omp_st == ST_OMP_SECTIONS 5390 || omp_st == ST_OMP_PARALLEL_SECTIONS)) 5391 { 5392 np = new_level (np); 5393 np->op = cp->op; 5394 np->block = NULL; 5395 } 5396 else if (st != omp_end_st) 5397 unexpected_statement (st); 5398 } 5399 while (st != omp_end_st); 5400 5401 switch (new_st.op) 5402 { 5403 case EXEC_OMP_END_NOWAIT: 5404 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; 5405 break; 5406 case EXEC_OMP_END_CRITICAL: 5407 if (((cp->ext.omp_clauses == NULL) ^ (new_st.ext.omp_name == NULL)) 5408 || (new_st.ext.omp_name != NULL 5409 && strcmp (cp->ext.omp_clauses->critical_name, 5410 new_st.ext.omp_name) != 0)) 5411 gfc_error ("Name after !$omp critical and !$omp end critical does " 5412 "not match at %C"); 5413 free (CONST_CAST (char *, new_st.ext.omp_name)); 5414 new_st.ext.omp_name = NULL; 5415 break; 5416 case EXEC_OMP_END_SINGLE: 5417 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] 5418 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]; 5419 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL; 5420 gfc_free_omp_clauses (new_st.ext.omp_clauses); 5421 break; 5422 case EXEC_NOP: 5423 break; 5424 default: 5425 gcc_unreachable (); 5426 } 5427 5428 gfc_clear_new_st (); 5429 gfc_commit_symbols (); 5430 gfc_warning_check (); 5431 pop_state (); 5432 } 5433 5434 5435 /* Accept a series of executable statements. We return the first 5436 statement that doesn't fit to the caller. Any block statements are 5437 passed on to the correct handler, which usually passes the buck 5438 right back here. */ 5439 5440 static gfc_statement 5441 parse_executable (gfc_statement st) 5442 { 5443 int close_flag; 5444 5445 if (st == ST_NONE) 5446 st = next_statement (); 5447 5448 for (;;) 5449 { 5450 close_flag = check_do_closure (); 5451 if (close_flag) 5452 switch (st) 5453 { 5454 case ST_GOTO: 5455 case ST_END_PROGRAM: 5456 case ST_RETURN: 5457 case ST_EXIT: 5458 case ST_END_FUNCTION: 5459 case ST_CYCLE: 5460 case ST_PAUSE: 5461 case ST_STOP: 5462 case ST_ERROR_STOP: 5463 case ST_END_SUBROUTINE: 5464 5465 case ST_DO: 5466 case ST_FORALL: 5467 case ST_WHERE: 5468 case ST_SELECT_CASE: 5469 gfc_error ("%s statement at %C cannot terminate a non-block " 5470 "DO loop", gfc_ascii_statement (st)); 5471 break; 5472 5473 default: 5474 break; 5475 } 5476 5477 switch (st) 5478 { 5479 case ST_NONE: 5480 unexpected_eof (); 5481 5482 case ST_DATA: 5483 gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the " 5484 "first executable statement"); 5485 /* Fall through. */ 5486 5487 case ST_FORMAT: 5488 case ST_ENTRY: 5489 case_executable: 5490 accept_statement (st); 5491 if (close_flag == 1) 5492 return ST_IMPLIED_ENDDO; 5493 break; 5494 5495 case ST_BLOCK: 5496 parse_block_construct (); 5497 break; 5498 5499 case ST_ASSOCIATE: 5500 parse_associate (); 5501 break; 5502 5503 case ST_IF_BLOCK: 5504 parse_if_block (); 5505 break; 5506 5507 case ST_SELECT_CASE: 5508 parse_select_block (); 5509 break; 5510 5511 case ST_SELECT_TYPE: 5512 parse_select_type_block (); 5513 break; 5514 5515 case ST_SELECT_RANK: 5516 parse_select_rank_block (); 5517 break; 5518 5519 case ST_DO: 5520 parse_do_block (); 5521 if (check_do_closure () == 1) 5522 return ST_IMPLIED_ENDDO; 5523 break; 5524 5525 case ST_CRITICAL: 5526 parse_critical_block (); 5527 break; 5528 5529 case ST_WHERE_BLOCK: 5530 parse_where_block (); 5531 break; 5532 5533 case ST_FORALL_BLOCK: 5534 parse_forall_block (); 5535 break; 5536 5537 case ST_OACC_PARALLEL_LOOP: 5538 case ST_OACC_KERNELS_LOOP: 5539 case ST_OACC_SERIAL_LOOP: 5540 case ST_OACC_LOOP: 5541 st = parse_oacc_loop (st); 5542 if (st == ST_IMPLIED_ENDDO) 5543 return st; 5544 continue; 5545 5546 case ST_OACC_PARALLEL: 5547 case ST_OACC_KERNELS: 5548 case ST_OACC_SERIAL: 5549 case ST_OACC_DATA: 5550 case ST_OACC_HOST_DATA: 5551 parse_oacc_structured_block (st); 5552 break; 5553 5554 case ST_OMP_PARALLEL: 5555 case ST_OMP_PARALLEL_SECTIONS: 5556 case ST_OMP_SECTIONS: 5557 case ST_OMP_ORDERED: 5558 case ST_OMP_CRITICAL: 5559 case ST_OMP_MASTER: 5560 case ST_OMP_SINGLE: 5561 case ST_OMP_TARGET: 5562 case ST_OMP_TARGET_DATA: 5563 case ST_OMP_TARGET_PARALLEL: 5564 case ST_OMP_TARGET_TEAMS: 5565 case ST_OMP_TEAMS: 5566 case ST_OMP_TASK: 5567 case ST_OMP_TASKGROUP: 5568 parse_omp_structured_block (st, false); 5569 break; 5570 5571 case ST_OMP_WORKSHARE: 5572 case ST_OMP_PARALLEL_WORKSHARE: 5573 parse_omp_structured_block (st, true); 5574 break; 5575 5576 case ST_OMP_DISTRIBUTE: 5577 case ST_OMP_DISTRIBUTE_PARALLEL_DO: 5578 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 5579 case ST_OMP_DISTRIBUTE_SIMD: 5580 case ST_OMP_DO: 5581 case ST_OMP_DO_SIMD: 5582 case ST_OMP_PARALLEL_DO: 5583 case ST_OMP_PARALLEL_DO_SIMD: 5584 case ST_OMP_SIMD: 5585 case ST_OMP_TARGET_PARALLEL_DO: 5586 case ST_OMP_TARGET_PARALLEL_DO_SIMD: 5587 case ST_OMP_TARGET_SIMD: 5588 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: 5589 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 5590 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5591 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 5592 case ST_OMP_TASKLOOP: 5593 case ST_OMP_TASKLOOP_SIMD: 5594 case ST_OMP_TEAMS_DISTRIBUTE: 5595 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 5596 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5597 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: 5598 st = parse_omp_do (st); 5599 if (st == ST_IMPLIED_ENDDO) 5600 return st; 5601 continue; 5602 5603 case ST_OACC_ATOMIC: 5604 st = parse_omp_oacc_atomic (false); 5605 continue; 5606 5607 case ST_OMP_ATOMIC: 5608 st = parse_omp_oacc_atomic (true); 5609 continue; 5610 5611 default: 5612 return st; 5613 } 5614 5615 if (directive_unroll != -1) 5616 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C"); 5617 5618 if (directive_ivdep) 5619 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C"); 5620 5621 if (directive_vector) 5622 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C"); 5623 5624 if (directive_novector) 5625 gfc_error ("%<GCC novector%> " 5626 "directive not at the start of a loop at %C"); 5627 5628 st = next_statement (); 5629 } 5630 } 5631 5632 5633 /* Fix the symbols for sibling functions. These are incorrectly added to 5634 the child namespace as the parser didn't know about this procedure. */ 5635 5636 static void 5637 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) 5638 { 5639 gfc_namespace *ns; 5640 gfc_symtree *st; 5641 gfc_symbol *old_sym; 5642 5643 for (ns = siblings; ns; ns = ns->sibling) 5644 { 5645 st = gfc_find_symtree (ns->sym_root, sym->name); 5646 5647 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) 5648 goto fixup_contained; 5649 5650 if ((st->n.sym->attr.flavor == FL_DERIVED 5651 && sym->attr.generic && sym->attr.function) 5652 ||(sym->attr.flavor == FL_DERIVED 5653 && st->n.sym->attr.generic && st->n.sym->attr.function)) 5654 goto fixup_contained; 5655 5656 old_sym = st->n.sym; 5657 if (old_sym->ns == ns 5658 && !old_sym->attr.contained 5659 5660 /* By 14.6.1.3, host association should be excluded 5661 for the following. */ 5662 && !(old_sym->attr.external 5663 || (old_sym->ts.type != BT_UNKNOWN 5664 && !old_sym->attr.implicit_type) 5665 || old_sym->attr.flavor == FL_PARAMETER 5666 || old_sym->attr.use_assoc 5667 || old_sym->attr.in_common 5668 || old_sym->attr.in_equivalence 5669 || old_sym->attr.data 5670 || old_sym->attr.dummy 5671 || old_sym->attr.result 5672 || old_sym->attr.dimension 5673 || old_sym->attr.allocatable 5674 || old_sym->attr.intrinsic 5675 || old_sym->attr.generic 5676 || old_sym->attr.flavor == FL_NAMELIST 5677 || old_sym->attr.flavor == FL_LABEL 5678 || old_sym->attr.proc == PROC_ST_FUNCTION)) 5679 { 5680 /* Replace it with the symbol from the parent namespace. */ 5681 st->n.sym = sym; 5682 sym->refs++; 5683 5684 gfc_release_symbol (old_sym); 5685 } 5686 5687 fixup_contained: 5688 /* Do the same for any contained procedures. */ 5689 gfc_fixup_sibling_symbols (sym, ns->contained); 5690 } 5691 } 5692 5693 static void 5694 parse_contained (int module) 5695 { 5696 gfc_namespace *ns, *parent_ns, *tmp; 5697 gfc_state_data s1, s2; 5698 gfc_statement st; 5699 gfc_symbol *sym; 5700 gfc_entry_list *el; 5701 locus old_loc; 5702 int contains_statements = 0; 5703 int seen_error = 0; 5704 5705 push_state (&s1, COMP_CONTAINS, NULL); 5706 parent_ns = gfc_current_ns; 5707 5708 do 5709 { 5710 gfc_current_ns = gfc_get_namespace (parent_ns, 1); 5711 5712 gfc_current_ns->sibling = parent_ns->contained; 5713 parent_ns->contained = gfc_current_ns; 5714 5715 next: 5716 /* Process the next available statement. We come here if we got an error 5717 and rejected the last statement. */ 5718 old_loc = gfc_current_locus; 5719 st = next_statement (); 5720 5721 switch (st) 5722 { 5723 case ST_NONE: 5724 unexpected_eof (); 5725 5726 case ST_FUNCTION: 5727 case ST_SUBROUTINE: 5728 contains_statements = 1; 5729 accept_statement (st); 5730 5731 push_state (&s2, 5732 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE, 5733 gfc_new_block); 5734 5735 /* For internal procedures, create/update the symbol in the 5736 parent namespace. */ 5737 5738 if (!module) 5739 { 5740 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym)) 5741 gfc_error ("Contained procedure %qs at %C is already " 5742 "ambiguous", gfc_new_block->name); 5743 else 5744 { 5745 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, 5746 sym->name, 5747 &gfc_new_block->declared_at)) 5748 { 5749 if (st == ST_FUNCTION) 5750 gfc_add_function (&sym->attr, sym->name, 5751 &gfc_new_block->declared_at); 5752 else 5753 gfc_add_subroutine (&sym->attr, sym->name, 5754 &gfc_new_block->declared_at); 5755 } 5756 } 5757 5758 gfc_commit_symbols (); 5759 } 5760 else 5761 sym = gfc_new_block; 5762 5763 /* Mark this as a contained function, so it isn't replaced 5764 by other module functions. */ 5765 sym->attr.contained = 1; 5766 5767 /* Set implicit_pure so that it can be reset if any of the 5768 tests for purity fail. This is used for some optimisation 5769 during translation. */ 5770 if (!sym->attr.pure) 5771 sym->attr.implicit_pure = 1; 5772 5773 parse_progunit (ST_NONE); 5774 5775 /* Fix up any sibling functions that refer to this one. */ 5776 gfc_fixup_sibling_symbols (sym, gfc_current_ns); 5777 /* Or refer to any of its alternate entry points. */ 5778 for (el = gfc_current_ns->entries; el; el = el->next) 5779 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns); 5780 5781 gfc_current_ns->code = s2.head; 5782 gfc_current_ns = parent_ns; 5783 5784 pop_state (); 5785 break; 5786 5787 /* These statements are associated with the end of the host unit. */ 5788 case ST_END_FUNCTION: 5789 case ST_END_MODULE: 5790 case ST_END_SUBMODULE: 5791 case ST_END_PROGRAM: 5792 case ST_END_SUBROUTINE: 5793 accept_statement (st); 5794 gfc_current_ns->code = s1.head; 5795 break; 5796 5797 default: 5798 gfc_error ("Unexpected %s statement in CONTAINS section at %C", 5799 gfc_ascii_statement (st)); 5800 reject_statement (); 5801 seen_error = 1; 5802 goto next; 5803 break; 5804 } 5805 } 5806 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE 5807 && st != ST_END_MODULE && st != ST_END_SUBMODULE 5808 && st != ST_END_PROGRAM); 5809 5810 /* The first namespace in the list is guaranteed to not have 5811 anything (worthwhile) in it. */ 5812 tmp = gfc_current_ns; 5813 gfc_current_ns = parent_ns; 5814 if (seen_error && tmp->refs > 1) 5815 gfc_free_namespace (tmp); 5816 5817 ns = gfc_current_ns->contained; 5818 gfc_current_ns->contained = ns->sibling; 5819 gfc_free_namespace (ns); 5820 5821 pop_state (); 5822 if (!contains_statements) 5823 gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without " 5824 "FUNCTION or SUBROUTINE statement at %L", &old_loc); 5825 } 5826 5827 5828 /* The result variable in a MODULE PROCEDURE needs to be created and 5829 its characteristics copied from the interface since it is neither 5830 declared in the procedure declaration nor in the specification 5831 part. */ 5832 5833 static void 5834 get_modproc_result (void) 5835 { 5836 gfc_symbol *proc; 5837 if (gfc_state_stack->previous 5838 && gfc_state_stack->previous->state == COMP_CONTAINS 5839 && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) 5840 { 5841 proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL; 5842 if (proc != NULL 5843 && proc->attr.function 5844 && proc->tlink 5845 && proc->tlink->result 5846 && proc->tlink->result != proc->tlink) 5847 { 5848 gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1); 5849 gfc_set_sym_referenced (proc->result); 5850 proc->result->attr.if_source = IFSRC_DECL; 5851 gfc_commit_symbol (proc->result); 5852 } 5853 } 5854 } 5855 5856 5857 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */ 5858 5859 static void 5860 parse_progunit (gfc_statement st) 5861 { 5862 gfc_state_data *p; 5863 int n; 5864 5865 gfc_adjust_builtins (); 5866 5867 if (gfc_new_block 5868 && gfc_new_block->abr_modproc_decl 5869 && gfc_new_block->attr.function) 5870 get_modproc_result (); 5871 5872 st = parse_spec (st); 5873 switch (st) 5874 { 5875 case ST_NONE: 5876 unexpected_eof (); 5877 5878 case ST_CONTAINS: 5879 /* This is not allowed within BLOCK! */ 5880 if (gfc_current_state () != COMP_BLOCK) 5881 goto contains; 5882 break; 5883 5884 case_end: 5885 accept_statement (st); 5886 goto done; 5887 5888 default: 5889 break; 5890 } 5891 5892 if (gfc_current_state () == COMP_FUNCTION) 5893 gfc_check_function_type (gfc_current_ns); 5894 5895 loop: 5896 for (;;) 5897 { 5898 st = parse_executable (st); 5899 5900 switch (st) 5901 { 5902 case ST_NONE: 5903 unexpected_eof (); 5904 5905 case ST_CONTAINS: 5906 /* This is not allowed within BLOCK! */ 5907 if (gfc_current_state () != COMP_BLOCK) 5908 goto contains; 5909 break; 5910 5911 case_end: 5912 accept_statement (st); 5913 goto done; 5914 5915 default: 5916 break; 5917 } 5918 5919 unexpected_statement (st); 5920 reject_statement (); 5921 st = next_statement (); 5922 } 5923 5924 contains: 5925 n = 0; 5926 5927 for (p = gfc_state_stack; p; p = p->previous) 5928 if (p->state == COMP_CONTAINS) 5929 n++; 5930 5931 if (gfc_find_state (COMP_MODULE) == true 5932 || gfc_find_state (COMP_SUBMODULE) == true) 5933 n--; 5934 5935 if (n > 0) 5936 { 5937 gfc_error ("CONTAINS statement at %C is already in a contained " 5938 "program unit"); 5939 reject_statement (); 5940 st = next_statement (); 5941 goto loop; 5942 } 5943 5944 parse_contained (0); 5945 5946 done: 5947 gfc_current_ns->code = gfc_state_stack->head; 5948 } 5949 5950 5951 /* Come here to complain about a global symbol already in use as 5952 something else. */ 5953 5954 void 5955 gfc_global_used (gfc_gsymbol *sym, locus *where) 5956 { 5957 const char *name; 5958 5959 if (where == NULL) 5960 where = &gfc_current_locus; 5961 5962 switch(sym->type) 5963 { 5964 case GSYM_PROGRAM: 5965 name = "PROGRAM"; 5966 break; 5967 case GSYM_FUNCTION: 5968 name = "FUNCTION"; 5969 break; 5970 case GSYM_SUBROUTINE: 5971 name = "SUBROUTINE"; 5972 break; 5973 case GSYM_COMMON: 5974 name = "COMMON"; 5975 break; 5976 case GSYM_BLOCK_DATA: 5977 name = "BLOCK DATA"; 5978 break; 5979 case GSYM_MODULE: 5980 name = "MODULE"; 5981 break; 5982 default: 5983 name = NULL; 5984 } 5985 5986 if (name) 5987 { 5988 if (sym->binding_label) 5989 gfc_error ("Global binding name %qs at %L is already being used " 5990 "as a %s at %L", sym->binding_label, where, name, 5991 &sym->where); 5992 else 5993 gfc_error ("Global name %qs at %L is already being used as " 5994 "a %s at %L", sym->name, where, name, &sym->where); 5995 } 5996 else 5997 { 5998 if (sym->binding_label) 5999 gfc_error ("Global binding name %qs at %L is already being used " 6000 "at %L", sym->binding_label, where, &sym->where); 6001 else 6002 gfc_error ("Global name %qs at %L is already being used at %L", 6003 sym->name, where, &sym->where); 6004 } 6005 } 6006 6007 6008 /* Parse a block data program unit. */ 6009 6010 static void 6011 parse_block_data (void) 6012 { 6013 gfc_statement st; 6014 static locus blank_locus; 6015 static int blank_block=0; 6016 gfc_gsymbol *s; 6017 6018 gfc_current_ns->proc_name = gfc_new_block; 6019 gfc_current_ns->is_block_data = 1; 6020 6021 if (gfc_new_block == NULL) 6022 { 6023 if (blank_block) 6024 gfc_error ("Blank BLOCK DATA at %C conflicts with " 6025 "prior BLOCK DATA at %L", &blank_locus); 6026 else 6027 { 6028 blank_block = 1; 6029 blank_locus = gfc_current_locus; 6030 } 6031 } 6032 else 6033 { 6034 s = gfc_get_gsymbol (gfc_new_block->name, false); 6035 if (s->defined 6036 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) 6037 gfc_global_used (s, &gfc_new_block->declared_at); 6038 else 6039 { 6040 s->type = GSYM_BLOCK_DATA; 6041 s->where = gfc_new_block->declared_at; 6042 s->defined = 1; 6043 } 6044 } 6045 6046 st = parse_spec (ST_NONE); 6047 6048 while (st != ST_END_BLOCK_DATA) 6049 { 6050 gfc_error ("Unexpected %s statement in BLOCK DATA at %C", 6051 gfc_ascii_statement (st)); 6052 reject_statement (); 6053 st = next_statement (); 6054 } 6055 } 6056 6057 6058 /* Following the association of the ancestor (sub)module symbols, they 6059 must be set host rather than use associated and all must be public. 6060 They are flagged up by 'used_in_submodule' so that they can be set 6061 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the 6062 linker chokes on multiple symbol definitions. */ 6063 6064 static void 6065 set_syms_host_assoc (gfc_symbol *sym) 6066 { 6067 gfc_component *c; 6068 const char dot[2] = "."; 6069 /* Symbols take the form module.submodule_ or module.name_. */ 6070 char parent1[2 * GFC_MAX_SYMBOL_LEN + 2]; 6071 char parent2[2 * GFC_MAX_SYMBOL_LEN + 2]; 6072 6073 if (sym == NULL) 6074 return; 6075 6076 if (sym->attr.module_procedure) 6077 sym->attr.external = 0; 6078 6079 sym->attr.use_assoc = 0; 6080 sym->attr.host_assoc = 1; 6081 sym->attr.used_in_submodule =1; 6082 6083 if (sym->attr.flavor == FL_DERIVED) 6084 { 6085 /* Derived types with PRIVATE components that are declared in 6086 modules other than the parent module must not be changed to be 6087 PUBLIC. The 'use-assoc' attribute must be reset so that the 6088 test in symbol.c(gfc_find_component) works correctly. This is 6089 not necessary for PRIVATE symbols since they are not read from 6090 the module. */ 6091 memset(parent1, '\0', sizeof(parent1)); 6092 memset(parent2, '\0', sizeof(parent2)); 6093 strcpy (parent1, gfc_new_block->name); 6094 strcpy (parent2, sym->module); 6095 if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0) 6096 { 6097 for (c = sym->components; c; c = c->next) 6098 c->attr.access = ACCESS_PUBLIC; 6099 } 6100 else 6101 { 6102 sym->attr.use_assoc = 1; 6103 sym->attr.host_assoc = 0; 6104 } 6105 } 6106 } 6107 6108 /* Parse a module subprogram. */ 6109 6110 static void 6111 parse_module (void) 6112 { 6113 gfc_statement st; 6114 gfc_gsymbol *s; 6115 bool error; 6116 6117 s = gfc_get_gsymbol (gfc_new_block->name, false); 6118 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE)) 6119 gfc_global_used (s, &gfc_new_block->declared_at); 6120 else 6121 { 6122 s->type = GSYM_MODULE; 6123 s->where = gfc_new_block->declared_at; 6124 s->defined = 1; 6125 } 6126 6127 /* Something is nulling the module_list after this point. This is good 6128 since it allows us to 'USE' the parent modules that the submodule 6129 inherits and to set (most) of the symbols as host associated. */ 6130 if (gfc_current_state () == COMP_SUBMODULE) 6131 { 6132 use_modules (); 6133 gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc); 6134 } 6135 6136 st = parse_spec (ST_NONE); 6137 6138 error = false; 6139 loop: 6140 switch (st) 6141 { 6142 case ST_NONE: 6143 unexpected_eof (); 6144 6145 case ST_CONTAINS: 6146 parse_contained (1); 6147 break; 6148 6149 case ST_END_MODULE: 6150 case ST_END_SUBMODULE: 6151 accept_statement (st); 6152 break; 6153 6154 default: 6155 gfc_error ("Unexpected %s statement in MODULE at %C", 6156 gfc_ascii_statement (st)); 6157 6158 error = true; 6159 reject_statement (); 6160 st = next_statement (); 6161 goto loop; 6162 } 6163 6164 /* Make sure not to free the namespace twice on error. */ 6165 if (!error) 6166 s->ns = gfc_current_ns; 6167 } 6168 6169 6170 /* Add a procedure name to the global symbol table. */ 6171 6172 static void 6173 add_global_procedure (bool sub) 6174 { 6175 gfc_gsymbol *s; 6176 6177 /* Only in Fortran 2003: For procedures with a binding label also the Fortran 6178 name is a global identifier. */ 6179 if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008)) 6180 { 6181 s = gfc_get_gsymbol (gfc_new_block->name, false); 6182 6183 if (s->defined 6184 || (s->type != GSYM_UNKNOWN 6185 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) 6186 { 6187 gfc_global_used (s, &gfc_new_block->declared_at); 6188 /* Silence follow-up errors. */ 6189 gfc_new_block->binding_label = NULL; 6190 } 6191 else 6192 { 6193 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; 6194 s->sym_name = gfc_new_block->name; 6195 s->where = gfc_new_block->declared_at; 6196 s->defined = 1; 6197 s->ns = gfc_current_ns; 6198 } 6199 } 6200 6201 /* Don't add the symbol multiple times. */ 6202 if (gfc_new_block->binding_label 6203 && (!gfc_notification_std (GFC_STD_F2008) 6204 || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0)) 6205 { 6206 s = gfc_get_gsymbol (gfc_new_block->binding_label, true); 6207 6208 if (s->defined 6209 || (s->type != GSYM_UNKNOWN 6210 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) 6211 { 6212 gfc_global_used (s, &gfc_new_block->declared_at); 6213 /* Silence follow-up errors. */ 6214 gfc_new_block->binding_label = NULL; 6215 } 6216 else 6217 { 6218 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; 6219 s->sym_name = gfc_new_block->name; 6220 s->binding_label = gfc_new_block->binding_label; 6221 s->where = gfc_new_block->declared_at; 6222 s->defined = 1; 6223 s->ns = gfc_current_ns; 6224 } 6225 } 6226 } 6227 6228 6229 /* Add a program to the global symbol table. */ 6230 6231 static void 6232 add_global_program (void) 6233 { 6234 gfc_gsymbol *s; 6235 6236 if (gfc_new_block == NULL) 6237 return; 6238 s = gfc_get_gsymbol (gfc_new_block->name, false); 6239 6240 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM)) 6241 gfc_global_used (s, &gfc_new_block->declared_at); 6242 else 6243 { 6244 s->type = GSYM_PROGRAM; 6245 s->where = gfc_new_block->declared_at; 6246 s->defined = 1; 6247 s->ns = gfc_current_ns; 6248 } 6249 } 6250 6251 6252 /* Resolve all the program units. */ 6253 static void 6254 resolve_all_program_units (gfc_namespace *gfc_global_ns_list) 6255 { 6256 gfc_derived_types = NULL; 6257 gfc_current_ns = gfc_global_ns_list; 6258 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) 6259 { 6260 if (gfc_current_ns->proc_name 6261 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) 6262 continue; /* Already resolved. */ 6263 6264 if (gfc_current_ns->proc_name) 6265 gfc_current_locus = gfc_current_ns->proc_name->declared_at; 6266 gfc_resolve (gfc_current_ns); 6267 gfc_current_ns->derived_types = gfc_derived_types; 6268 gfc_derived_types = NULL; 6269 } 6270 } 6271 6272 6273 static void 6274 clean_up_modules (gfc_gsymbol *gsym) 6275 { 6276 if (gsym == NULL) 6277 return; 6278 6279 clean_up_modules (gsym->left); 6280 clean_up_modules (gsym->right); 6281 6282 if (gsym->type != GSYM_MODULE || !gsym->ns) 6283 return; 6284 6285 gfc_current_ns = gsym->ns; 6286 gfc_derived_types = gfc_current_ns->derived_types; 6287 gfc_done_2 (); 6288 gsym->ns = NULL; 6289 return; 6290 } 6291 6292 6293 /* Translate all the program units. This could be in a different order 6294 to resolution if there are forward references in the file. */ 6295 static void 6296 translate_all_program_units (gfc_namespace *gfc_global_ns_list) 6297 { 6298 int errors; 6299 6300 gfc_current_ns = gfc_global_ns_list; 6301 gfc_get_errors (NULL, &errors); 6302 6303 /* We first translate all modules to make sure that later parts 6304 of the program can use the decl. Then we translate the nonmodules. */ 6305 6306 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) 6307 { 6308 if (!gfc_current_ns->proc_name 6309 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) 6310 continue; 6311 6312 gfc_current_locus = gfc_current_ns->proc_name->declared_at; 6313 gfc_derived_types = gfc_current_ns->derived_types; 6314 gfc_generate_module_code (gfc_current_ns); 6315 gfc_current_ns->translated = 1; 6316 } 6317 6318 gfc_current_ns = gfc_global_ns_list; 6319 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) 6320 { 6321 if (gfc_current_ns->proc_name 6322 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) 6323 continue; 6324 6325 gfc_current_locus = gfc_current_ns->proc_name->declared_at; 6326 gfc_derived_types = gfc_current_ns->derived_types; 6327 gfc_generate_code (gfc_current_ns); 6328 gfc_current_ns->translated = 1; 6329 } 6330 6331 /* Clean up all the namespaces after translation. */ 6332 gfc_current_ns = gfc_global_ns_list; 6333 for (;gfc_current_ns;) 6334 { 6335 gfc_namespace *ns; 6336 6337 if (gfc_current_ns->proc_name 6338 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) 6339 { 6340 gfc_current_ns = gfc_current_ns->sibling; 6341 continue; 6342 } 6343 6344 ns = gfc_current_ns->sibling; 6345 gfc_derived_types = gfc_current_ns->derived_types; 6346 gfc_done_2 (); 6347 gfc_current_ns = ns; 6348 } 6349 6350 clean_up_modules (gfc_gsym_root); 6351 } 6352 6353 6354 /* Top level parser. */ 6355 6356 bool 6357 gfc_parse_file (void) 6358 { 6359 int seen_program, errors_before, errors; 6360 gfc_state_data top, s; 6361 gfc_statement st; 6362 locus prog_locus; 6363 gfc_namespace *next; 6364 6365 gfc_start_source_files (); 6366 6367 top.state = COMP_NONE; 6368 top.sym = NULL; 6369 top.previous = NULL; 6370 top.head = top.tail = NULL; 6371 top.do_variable = NULL; 6372 6373 gfc_state_stack = ⊤ 6374 6375 gfc_clear_new_st (); 6376 6377 gfc_statement_label = NULL; 6378 6379 if (setjmp (eof_buf)) 6380 return false; /* Come here on unexpected EOF */ 6381 6382 /* Prepare the global namespace that will contain the 6383 program units. */ 6384 gfc_global_ns_list = next = NULL; 6385 6386 seen_program = 0; 6387 errors_before = 0; 6388 6389 /* Exit early for empty files. */ 6390 if (gfc_at_eof ()) 6391 goto done; 6392 6393 in_specification_block = true; 6394 loop: 6395 gfc_init_2 (); 6396 st = next_statement (); 6397 switch (st) 6398 { 6399 case ST_NONE: 6400 gfc_done_2 (); 6401 goto done; 6402 6403 case ST_PROGRAM: 6404 if (seen_program) 6405 goto duplicate_main; 6406 seen_program = 1; 6407 prog_locus = gfc_current_locus; 6408 6409 push_state (&s, COMP_PROGRAM, gfc_new_block); 6410 main_program_symbol (gfc_current_ns, gfc_new_block->name); 6411 accept_statement (st); 6412 add_global_program (); 6413 parse_progunit (ST_NONE); 6414 goto prog_units; 6415 6416 case ST_SUBROUTINE: 6417 add_global_procedure (true); 6418 push_state (&s, COMP_SUBROUTINE, gfc_new_block); 6419 accept_statement (st); 6420 parse_progunit (ST_NONE); 6421 goto prog_units; 6422 6423 case ST_FUNCTION: 6424 add_global_procedure (false); 6425 push_state (&s, COMP_FUNCTION, gfc_new_block); 6426 accept_statement (st); 6427 parse_progunit (ST_NONE); 6428 goto prog_units; 6429 6430 case ST_BLOCK_DATA: 6431 push_state (&s, COMP_BLOCK_DATA, gfc_new_block); 6432 accept_statement (st); 6433 parse_block_data (); 6434 break; 6435 6436 case ST_MODULE: 6437 push_state (&s, COMP_MODULE, gfc_new_block); 6438 accept_statement (st); 6439 6440 gfc_get_errors (NULL, &errors_before); 6441 parse_module (); 6442 break; 6443 6444 case ST_SUBMODULE: 6445 push_state (&s, COMP_SUBMODULE, gfc_new_block); 6446 accept_statement (st); 6447 6448 gfc_get_errors (NULL, &errors_before); 6449 parse_module (); 6450 break; 6451 6452 /* Anything else starts a nameless main program block. */ 6453 default: 6454 if (seen_program) 6455 goto duplicate_main; 6456 seen_program = 1; 6457 prog_locus = gfc_current_locus; 6458 6459 push_state (&s, COMP_PROGRAM, gfc_new_block); 6460 main_program_symbol (gfc_current_ns, "MAIN__"); 6461 parse_progunit (st); 6462 goto prog_units; 6463 } 6464 6465 /* Handle the non-program units. */ 6466 gfc_current_ns->code = s.head; 6467 6468 gfc_resolve (gfc_current_ns); 6469 6470 /* Fix the implicit_pure attribute for those procedures who should 6471 not have it. */ 6472 while (gfc_fix_implicit_pure (gfc_current_ns)) 6473 ; 6474 6475 /* Dump the parse tree if requested. */ 6476 if (flag_dump_fortran_original) 6477 gfc_dump_parse_tree (gfc_current_ns, stdout); 6478 6479 gfc_get_errors (NULL, &errors); 6480 if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE) 6481 { 6482 gfc_dump_module (s.sym->name, errors_before == errors); 6483 gfc_current_ns->derived_types = gfc_derived_types; 6484 gfc_derived_types = NULL; 6485 goto prog_units; 6486 } 6487 else 6488 { 6489 if (errors == 0) 6490 gfc_generate_code (gfc_current_ns); 6491 pop_state (); 6492 gfc_done_2 (); 6493 } 6494 6495 goto loop; 6496 6497 prog_units: 6498 /* The main program and non-contained procedures are put 6499 in the global namespace list, so that they can be processed 6500 later and all their interfaces resolved. */ 6501 gfc_current_ns->code = s.head; 6502 if (next) 6503 { 6504 for (; next->sibling; next = next->sibling) 6505 ; 6506 next->sibling = gfc_current_ns; 6507 } 6508 else 6509 gfc_global_ns_list = gfc_current_ns; 6510 6511 next = gfc_current_ns; 6512 6513 pop_state (); 6514 goto loop; 6515 6516 done: 6517 /* Do the resolution. */ 6518 resolve_all_program_units (gfc_global_ns_list); 6519 6520 /* Go through all top-level namespaces and unset the implicit_pure 6521 attribute for any procedures that call something not pure or 6522 implicit_pure. Because the a procedure marked as not implicit_pure 6523 in one sweep may be called by another routine, we repeat this 6524 process until there are no more changes. */ 6525 bool changed; 6526 do 6527 { 6528 changed = false; 6529 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; 6530 gfc_current_ns = gfc_current_ns->sibling) 6531 { 6532 if (gfc_fix_implicit_pure (gfc_current_ns)) 6533 changed = true; 6534 } 6535 } 6536 while (changed); 6537 6538 /* Fixup for external procedures. */ 6539 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; 6540 gfc_current_ns = gfc_current_ns->sibling) 6541 gfc_check_externals (gfc_current_ns); 6542 6543 /* Do the parse tree dump. */ 6544 gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; 6545 6546 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) 6547 if (!gfc_current_ns->proc_name 6548 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) 6549 { 6550 gfc_dump_parse_tree (gfc_current_ns, stdout); 6551 fputs ("------------------------------------------\n\n", stdout); 6552 } 6553 6554 /* Dump C prototypes. */ 6555 if (flag_c_prototypes || flag_c_prototypes_external) 6556 { 6557 fprintf (stdout, 6558 "#include <stddef.h>\n" 6559 "#ifdef __cplusplus\n" 6560 "#include <complex>\n" 6561 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n" 6562 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n" 6563 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n" 6564 "extern \"C\" {\n" 6565 "#else\n" 6566 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n" 6567 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n" 6568 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n" 6569 "#endif\n\n"); 6570 } 6571 6572 /* First dump BIND(C) prototypes. */ 6573 if (flag_c_prototypes) 6574 { 6575 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; 6576 gfc_current_ns = gfc_current_ns->sibling) 6577 gfc_dump_c_prototypes (gfc_current_ns, stdout); 6578 } 6579 6580 /* Dump external prototypes. */ 6581 if (flag_c_prototypes_external) 6582 gfc_dump_external_c_prototypes (stdout); 6583 6584 if (flag_c_prototypes || flag_c_prototypes_external) 6585 fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n"); 6586 6587 /* Do the translation. */ 6588 translate_all_program_units (gfc_global_ns_list); 6589 6590 /* Dump the global symbol ist. We only do this here because part 6591 of it is generated after mangling the identifiers in 6592 trans-decl.c. */ 6593 6594 if (flag_dump_fortran_global) 6595 gfc_dump_global_symbols (stdout); 6596 6597 gfc_end_source_files (); 6598 return true; 6599 6600 duplicate_main: 6601 /* If we see a duplicate main program, shut down. If the second 6602 instance is an implied main program, i.e. data decls or executable 6603 statements, we're in for lots of errors. */ 6604 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); 6605 reject_statement (); 6606 gfc_done_2 (); 6607 return true; 6608 } 6609 6610 /* Return true if this state data represents an OpenACC region. */ 6611 bool 6612 is_oacc (gfc_state_data *sd) 6613 { 6614 switch (sd->construct->op) 6615 { 6616 case EXEC_OACC_PARALLEL_LOOP: 6617 case EXEC_OACC_PARALLEL: 6618 case EXEC_OACC_KERNELS_LOOP: 6619 case EXEC_OACC_KERNELS: 6620 case EXEC_OACC_SERIAL_LOOP: 6621 case EXEC_OACC_SERIAL: 6622 case EXEC_OACC_DATA: 6623 case EXEC_OACC_HOST_DATA: 6624 case EXEC_OACC_LOOP: 6625 case EXEC_OACC_UPDATE: 6626 case EXEC_OACC_WAIT: 6627 case EXEC_OACC_CACHE: 6628 case EXEC_OACC_ENTER_DATA: 6629 case EXEC_OACC_EXIT_DATA: 6630 case EXEC_OACC_ATOMIC: 6631 case EXEC_OACC_ROUTINE: 6632 return true; 6633 6634 default: 6635 return false; 6636 } 6637 } 6638