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