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