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