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