1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Debug; use Debug; 28with Debug_A; use Debug_A; 29with Elists; use Elists; 30with Exp_SPARK; use Exp_SPARK; 31with Expander; use Expander; 32with Ghost; use Ghost; 33with Lib; use Lib; 34with Lib.Load; use Lib.Load; 35with Nlists; use Nlists; 36with Output; use Output; 37with Restrict; use Restrict; 38with Sem_Attr; use Sem_Attr; 39with Sem_Aux; use Sem_Aux; 40with Sem_Ch2; use Sem_Ch2; 41with Sem_Ch3; use Sem_Ch3; 42with Sem_Ch4; use Sem_Ch4; 43with Sem_Ch5; use Sem_Ch5; 44with Sem_Ch6; use Sem_Ch6; 45with Sem_Ch7; use Sem_Ch7; 46with Sem_Ch8; use Sem_Ch8; 47with Sem_Ch9; use Sem_Ch9; 48with Sem_Ch10; use Sem_Ch10; 49with Sem_Ch11; use Sem_Ch11; 50with Sem_Ch12; use Sem_Ch12; 51with Sem_Ch13; use Sem_Ch13; 52with Sem_Prag; use Sem_Prag; 53with Sem_Util; use Sem_Util; 54with Sinfo; use Sinfo; 55with Stand; use Stand; 56with Stylesw; use Stylesw; 57with Uintp; use Uintp; 58with Uname; use Uname; 59 60with Unchecked_Deallocation; 61 62pragma Warnings (Off, Sem_Util); 63-- Suppress warnings of unused with for Sem_Util (used only in asserts) 64 65package body Sem is 66 67 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW; 68 -- Controls debugging printouts for Walk_Library_Items 69 70 Outer_Generic_Scope : Entity_Id := Empty; 71 -- Global reference to the outer scope that is generic. In a non-generic 72 -- context, it is empty. At the moment, it is only used for avoiding 73 -- freezing of external references in generics. 74 75 Comp_Unit_List : Elist_Id := No_Elist; 76 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes 77 -- processed by Semantics, in an appropriate order. Initialized to 78 -- No_Elist, because it's too early to call New_Elmt_List; we will set it 79 -- to New_Elmt_List on first use. 80 81 generic 82 with procedure Action (Withed_Unit : Node_Id); 83 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); 84 -- Walk all the with clauses of CU, and call Action for the with'ed unit. 85 -- Ignore limited withs, unless Include_Limited is True. CU must be an 86 -- N_Compilation_Unit. 87 88 generic 89 with procedure Action (Withed_Unit : Node_Id); 90 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean); 91 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits 92 -- of this unit, since they count as dependences on their parent library 93 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit. 94 95 ------------- 96 -- Analyze -- 97 ------------- 98 99 -- WARNING: This routine manages Ghost regions. Return statements must be 100 -- replaced by gotos which jump to the end of the routine and restore the 101 -- Ghost mode. 102 103 procedure Analyze (N : Node_Id) is 104 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 105 -- Save the Ghost mode to restore on exit 106 107 begin 108 Debug_A_Entry ("analyzing ", N); 109 110 -- Immediate return if already analyzed 111 112 if Analyzed (N) then 113 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)"); 114 return; 115 end if; 116 117 -- A declaration may be subject to pragma Ghost. Set the mode now to 118 -- ensure that any nodes generated during analysis and expansion are 119 -- marked as Ghost. 120 121 if Is_Declaration (N) then 122 Mark_And_Set_Ghost_Declaration (N); 123 end if; 124 125 -- Otherwise processing depends on the node kind 126 127 case Nkind (N) is 128 when N_Abort_Statement => 129 Analyze_Abort_Statement (N); 130 131 when N_Abstract_Subprogram_Declaration => 132 Analyze_Abstract_Subprogram_Declaration (N); 133 134 when N_Accept_Alternative => 135 Analyze_Accept_Alternative (N); 136 137 when N_Accept_Statement => 138 Analyze_Accept_Statement (N); 139 140 when N_Aggregate => 141 Analyze_Aggregate (N); 142 143 when N_Allocator => 144 Analyze_Allocator (N); 145 146 when N_And_Then => 147 Analyze_Short_Circuit (N); 148 149 when N_Assignment_Statement => 150 Analyze_Assignment (N); 151 152 when N_Asynchronous_Select => 153 Analyze_Asynchronous_Select (N); 154 155 when N_At_Clause => 156 Analyze_At_Clause (N); 157 158 when N_Attribute_Reference => 159 Analyze_Attribute (N); 160 161 when N_Attribute_Definition_Clause => 162 Analyze_Attribute_Definition_Clause (N); 163 164 when N_Block_Statement => 165 Analyze_Block_Statement (N); 166 167 when N_Case_Expression => 168 Analyze_Case_Expression (N); 169 170 when N_Case_Statement => 171 Analyze_Case_Statement (N); 172 173 when N_Character_Literal => 174 Analyze_Character_Literal (N); 175 176 when N_Code_Statement => 177 Analyze_Code_Statement (N); 178 179 when N_Compilation_Unit => 180 Analyze_Compilation_Unit (N); 181 182 when N_Component_Declaration => 183 Analyze_Component_Declaration (N); 184 185 when N_Compound_Statement => 186 Analyze_Compound_Statement (N); 187 188 when N_Conditional_Entry_Call => 189 Analyze_Conditional_Entry_Call (N); 190 191 when N_Delay_Alternative => 192 Analyze_Delay_Alternative (N); 193 194 when N_Delay_Relative_Statement => 195 Analyze_Delay_Relative (N); 196 197 when N_Delay_Until_Statement => 198 Analyze_Delay_Until (N); 199 200 when N_Delta_Aggregate => 201 Analyze_Aggregate (N); 202 203 when N_Entry_Body => 204 Analyze_Entry_Body (N); 205 206 when N_Entry_Body_Formal_Part => 207 Analyze_Entry_Body_Formal_Part (N); 208 209 when N_Entry_Call_Alternative => 210 Analyze_Entry_Call_Alternative (N); 211 212 when N_Entry_Declaration => 213 Analyze_Entry_Declaration (N); 214 215 when N_Entry_Index_Specification => 216 Analyze_Entry_Index_Specification (N); 217 218 when N_Enumeration_Representation_Clause => 219 Analyze_Enumeration_Representation_Clause (N); 220 221 when N_Exception_Declaration => 222 Analyze_Exception_Declaration (N); 223 224 when N_Exception_Renaming_Declaration => 225 Analyze_Exception_Renaming (N); 226 227 when N_Exit_Statement => 228 Analyze_Exit_Statement (N); 229 230 when N_Expanded_Name => 231 Analyze_Expanded_Name (N); 232 233 when N_Explicit_Dereference => 234 Analyze_Explicit_Dereference (N); 235 236 when N_Expression_Function => 237 Analyze_Expression_Function (N); 238 239 when N_Expression_With_Actions => 240 Analyze_Expression_With_Actions (N); 241 242 when N_Extended_Return_Statement => 243 Analyze_Extended_Return_Statement (N); 244 245 when N_Extension_Aggregate => 246 Analyze_Aggregate (N); 247 248 when N_Formal_Object_Declaration => 249 Analyze_Formal_Object_Declaration (N); 250 251 when N_Formal_Package_Declaration => 252 Analyze_Formal_Package_Declaration (N); 253 254 when N_Formal_Subprogram_Declaration => 255 Analyze_Formal_Subprogram_Declaration (N); 256 257 when N_Formal_Type_Declaration => 258 Analyze_Formal_Type_Declaration (N); 259 260 when N_Free_Statement => 261 Analyze_Free_Statement (N); 262 263 when N_Freeze_Entity => 264 Analyze_Freeze_Entity (N); 265 266 when N_Freeze_Generic_Entity => 267 Analyze_Freeze_Generic_Entity (N); 268 269 when N_Full_Type_Declaration => 270 Analyze_Full_Type_Declaration (N); 271 272 when N_Function_Call => 273 Analyze_Function_Call (N); 274 275 when N_Function_Instantiation => 276 Analyze_Function_Instantiation (N); 277 278 when N_Generic_Function_Renaming_Declaration => 279 Analyze_Generic_Function_Renaming (N); 280 281 when N_Generic_Package_Declaration => 282 Analyze_Generic_Package_Declaration (N); 283 284 when N_Generic_Package_Renaming_Declaration => 285 Analyze_Generic_Package_Renaming (N); 286 287 when N_Generic_Procedure_Renaming_Declaration => 288 Analyze_Generic_Procedure_Renaming (N); 289 290 when N_Generic_Subprogram_Declaration => 291 Analyze_Generic_Subprogram_Declaration (N); 292 293 when N_Goto_Statement => 294 Analyze_Goto_Statement (N); 295 296 when N_Handled_Sequence_Of_Statements => 297 Analyze_Handled_Statements (N); 298 299 when N_Identifier => 300 Analyze_Identifier (N); 301 302 when N_If_Expression => 303 Analyze_If_Expression (N); 304 305 when N_If_Statement => 306 Analyze_If_Statement (N); 307 308 when N_Implicit_Label_Declaration => 309 Analyze_Implicit_Label_Declaration (N); 310 311 when N_In => 312 Analyze_Membership_Op (N); 313 314 when N_Incomplete_Type_Declaration => 315 Analyze_Incomplete_Type_Decl (N); 316 317 when N_Indexed_Component => 318 Analyze_Indexed_Component_Form (N); 319 320 when N_Integer_Literal => 321 Analyze_Integer_Literal (N); 322 323 when N_Iterator_Specification => 324 Analyze_Iterator_Specification (N); 325 326 when N_Itype_Reference => 327 Analyze_Itype_Reference (N); 328 329 when N_Label => 330 Analyze_Label (N); 331 332 when N_Loop_Parameter_Specification => 333 Analyze_Loop_Parameter_Specification (N); 334 335 when N_Loop_Statement => 336 Analyze_Loop_Statement (N); 337 338 when N_Not_In => 339 Analyze_Membership_Op (N); 340 341 when N_Null => 342 Analyze_Null (N); 343 344 when N_Null_Statement => 345 Analyze_Null_Statement (N); 346 347 when N_Number_Declaration => 348 Analyze_Number_Declaration (N); 349 350 when N_Object_Declaration => 351 Analyze_Object_Declaration (N); 352 353 when N_Object_Renaming_Declaration => 354 Analyze_Object_Renaming (N); 355 356 when N_Operator_Symbol => 357 Analyze_Operator_Symbol (N); 358 359 when N_Op_Abs => 360 Analyze_Unary_Op (N); 361 362 when N_Op_Add => 363 Analyze_Arithmetic_Op (N); 364 365 when N_Op_And => 366 Analyze_Logical_Op (N); 367 368 when N_Op_Concat => 369 Analyze_Concatenation (N); 370 371 when N_Op_Divide => 372 Analyze_Arithmetic_Op (N); 373 374 when N_Op_Eq => 375 Analyze_Equality_Op (N); 376 377 when N_Op_Expon => 378 Analyze_Arithmetic_Op (N); 379 380 when N_Op_Ge => 381 Analyze_Comparison_Op (N); 382 383 when N_Op_Gt => 384 Analyze_Comparison_Op (N); 385 386 when N_Op_Le => 387 Analyze_Comparison_Op (N); 388 389 when N_Op_Lt => 390 Analyze_Comparison_Op (N); 391 392 when N_Op_Minus => 393 Analyze_Unary_Op (N); 394 395 when N_Op_Mod => 396 Analyze_Mod (N); 397 398 when N_Op_Multiply => 399 Analyze_Arithmetic_Op (N); 400 401 when N_Op_Ne => 402 Analyze_Equality_Op (N); 403 404 when N_Op_Not => 405 Analyze_Negation (N); 406 407 when N_Op_Or => 408 Analyze_Logical_Op (N); 409 410 when N_Op_Plus => 411 Analyze_Unary_Op (N); 412 413 when N_Op_Rem => 414 Analyze_Arithmetic_Op (N); 415 416 when N_Op_Rotate_Left => 417 Analyze_Arithmetic_Op (N); 418 419 when N_Op_Rotate_Right => 420 Analyze_Arithmetic_Op (N); 421 422 when N_Op_Shift_Left => 423 Analyze_Arithmetic_Op (N); 424 425 when N_Op_Shift_Right => 426 Analyze_Arithmetic_Op (N); 427 428 when N_Op_Shift_Right_Arithmetic => 429 Analyze_Arithmetic_Op (N); 430 431 when N_Op_Subtract => 432 Analyze_Arithmetic_Op (N); 433 434 when N_Op_Xor => 435 Analyze_Logical_Op (N); 436 437 when N_Or_Else => 438 Analyze_Short_Circuit (N); 439 440 when N_Others_Choice => 441 Analyze_Others_Choice (N); 442 443 when N_Package_Body => 444 Analyze_Package_Body (N); 445 446 when N_Package_Body_Stub => 447 Analyze_Package_Body_Stub (N); 448 449 when N_Package_Declaration => 450 Analyze_Package_Declaration (N); 451 452 when N_Package_Instantiation => 453 Analyze_Package_Instantiation (N); 454 455 when N_Package_Renaming_Declaration => 456 Analyze_Package_Renaming (N); 457 458 when N_Package_Specification => 459 Analyze_Package_Specification (N); 460 461 when N_Parameter_Association => 462 Analyze_Parameter_Association (N); 463 464 when N_Pragma => 465 Analyze_Pragma (N); 466 467 when N_Private_Extension_Declaration => 468 Analyze_Private_Extension_Declaration (N); 469 470 when N_Private_Type_Declaration => 471 Analyze_Private_Type_Declaration (N); 472 473 when N_Procedure_Call_Statement => 474 Analyze_Procedure_Call (N); 475 476 when N_Procedure_Instantiation => 477 Analyze_Procedure_Instantiation (N); 478 479 when N_Protected_Body => 480 Analyze_Protected_Body (N); 481 482 when N_Protected_Body_Stub => 483 Analyze_Protected_Body_Stub (N); 484 485 when N_Protected_Definition => 486 Analyze_Protected_Definition (N); 487 488 when N_Protected_Type_Declaration => 489 Analyze_Protected_Type_Declaration (N); 490 491 when N_Qualified_Expression => 492 Analyze_Qualified_Expression (N); 493 494 when N_Quantified_Expression => 495 Analyze_Quantified_Expression (N); 496 497 when N_Raise_Expression => 498 Analyze_Raise_Expression (N); 499 500 when N_Raise_Statement => 501 Analyze_Raise_Statement (N); 502 503 when N_Raise_xxx_Error => 504 Analyze_Raise_xxx_Error (N); 505 506 when N_Range => 507 Analyze_Range (N); 508 509 when N_Range_Constraint => 510 Analyze_Range (Range_Expression (N)); 511 512 when N_Real_Literal => 513 Analyze_Real_Literal (N); 514 515 when N_Record_Representation_Clause => 516 Analyze_Record_Representation_Clause (N); 517 518 when N_Reduction_Expression => 519 Analyze_Reduction_Expression (N); 520 521 when N_Reduction_Expression_Parameter => 522 Analyze_Reduction_Expression_Parameter (N); 523 524 when N_Reference => 525 Analyze_Reference (N); 526 527 when N_Requeue_Statement => 528 Analyze_Requeue (N); 529 530 when N_Simple_Return_Statement => 531 Analyze_Simple_Return_Statement (N); 532 533 when N_Selected_Component => 534 Find_Selected_Component (N); 535 -- ??? why not Analyze_Selected_Component, needs comments 536 537 when N_Selective_Accept => 538 Analyze_Selective_Accept (N); 539 540 when N_Single_Protected_Declaration => 541 Analyze_Single_Protected_Declaration (N); 542 543 when N_Single_Task_Declaration => 544 Analyze_Single_Task_Declaration (N); 545 546 when N_Slice => 547 Analyze_Slice (N); 548 549 when N_String_Literal => 550 Analyze_String_Literal (N); 551 552 when N_Subprogram_Body => 553 Analyze_Subprogram_Body (N); 554 555 when N_Subprogram_Body_Stub => 556 Analyze_Subprogram_Body_Stub (N); 557 558 when N_Subprogram_Declaration => 559 Analyze_Subprogram_Declaration (N); 560 561 when N_Subprogram_Renaming_Declaration => 562 Analyze_Subprogram_Renaming (N); 563 564 when N_Subtype_Declaration => 565 Analyze_Subtype_Declaration (N); 566 567 when N_Subtype_Indication => 568 Analyze_Subtype_Indication (N); 569 570 when N_Subunit => 571 Analyze_Subunit (N); 572 573 when N_Target_Name => 574 Analyze_Target_Name (N); 575 576 when N_Task_Body => 577 Analyze_Task_Body (N); 578 579 when N_Task_Body_Stub => 580 Analyze_Task_Body_Stub (N); 581 582 when N_Task_Definition => 583 Analyze_Task_Definition (N); 584 585 when N_Task_Type_Declaration => 586 Analyze_Task_Type_Declaration (N); 587 588 when N_Terminate_Alternative => 589 Analyze_Terminate_Alternative (N); 590 591 when N_Timed_Entry_Call => 592 Analyze_Timed_Entry_Call (N); 593 594 when N_Triggering_Alternative => 595 Analyze_Triggering_Alternative (N); 596 597 when N_Type_Conversion => 598 Analyze_Type_Conversion (N); 599 600 when N_Unchecked_Expression => 601 Analyze_Unchecked_Expression (N); 602 603 when N_Unchecked_Type_Conversion => 604 Analyze_Unchecked_Type_Conversion (N); 605 606 when N_Use_Package_Clause => 607 Analyze_Use_Package (N); 608 609 when N_Use_Type_Clause => 610 Analyze_Use_Type (N); 611 612 when N_Validate_Unchecked_Conversion => 613 null; 614 615 when N_Variant_Part => 616 Analyze_Variant_Part (N); 617 618 when N_With_Clause => 619 Analyze_With_Clause (N); 620 621 -- A call to analyze a marker is ignored because the node does not 622 -- have any static and run-time semantics. 623 624 when N_Call_Marker 625 | N_Variable_Reference_Marker 626 => 627 null; 628 629 -- A call to analyze the Empty node is an error, but most likely it 630 -- is an error caused by an attempt to analyze a malformed piece of 631 -- tree caused by some other error, so if there have been any other 632 -- errors, we just ignore it, otherwise it is a real internal error 633 -- which we complain about. 634 635 -- We must also consider the case of call to a runtime function that 636 -- is not available in the configurable runtime. 637 638 when N_Empty => 639 pragma Assert (Serious_Errors_Detected /= 0 640 or else Configurable_Run_Time_Violations /= 0); 641 null; 642 643 -- A call to analyze the error node is simply ignored, to avoid 644 -- causing cascaded errors (happens of course only in error cases) 645 -- Disable expansion in case it is still enabled, to prevent other 646 -- subsequent compiler glitches. 647 648 when N_Error => 649 Expander_Mode_Save_And_Set (False); 650 null; 651 652 -- Push/Pop nodes normally don't come through an analyze call. An 653 -- exception is the dummy ones bracketing a subprogram body. In any 654 -- case there is nothing to be done to analyze such nodes. 655 656 when N_Push_Pop_xxx_Label => 657 null; 658 659 -- SCIL nodes don't need analysis because they are decorated when 660 -- they are built. They are added to the tree by Insert_Actions and 661 -- the call to analyze them is generated when the full list is 662 -- analyzed. 663 664 when N_SCIL_Dispatch_Table_Tag_Init 665 | N_SCIL_Dispatching_Call 666 | N_SCIL_Membership_Test 667 => 668 null; 669 670 -- A quantified expression with a missing "all" or "some" qualifier 671 -- looks identical to an iterated component association. By language 672 -- definition, the latter must be present within array aggregates. If 673 -- this is not the case, then the iterated component association is 674 -- really an illegal quantified expression. Diagnose this scenario. 675 676 when N_Iterated_Component_Association => 677 Diagnose_Iterated_Component_Association (N); 678 679 -- For the remaining node types, we generate compiler abort, because 680 -- these nodes are always analyzed within the Sem_Chn routines and 681 -- there should never be a case of making a call to the main Analyze 682 -- routine for these node kinds. For example, an N_Access_Definition 683 -- node appears only in the context of a type declaration, and is 684 -- processed by the analyze routine for type declarations. 685 686 when N_Abortable_Part 687 | N_Access_Definition 688 | N_Access_Function_Definition 689 | N_Access_Procedure_Definition 690 | N_Access_To_Object_Definition 691 | N_Aspect_Specification 692 | N_Case_Expression_Alternative 693 | N_Case_Statement_Alternative 694 | N_Compilation_Unit_Aux 695 | N_Component_Association 696 | N_Component_Clause 697 | N_Component_Definition 698 | N_Component_List 699 | N_Constrained_Array_Definition 700 | N_Contract 701 | N_Decimal_Fixed_Point_Definition 702 | N_Defining_Character_Literal 703 | N_Defining_Identifier 704 | N_Defining_Operator_Symbol 705 | N_Defining_Program_Unit_Name 706 | N_Delta_Constraint 707 | N_Derived_Type_Definition 708 | N_Designator 709 | N_Digits_Constraint 710 | N_Discriminant_Association 711 | N_Discriminant_Specification 712 | N_Elsif_Part 713 | N_Entry_Call_Statement 714 | N_Enumeration_Type_Definition 715 | N_Exception_Handler 716 | N_Floating_Point_Definition 717 | N_Formal_Decimal_Fixed_Point_Definition 718 | N_Formal_Derived_Type_Definition 719 | N_Formal_Discrete_Type_Definition 720 | N_Formal_Floating_Point_Definition 721 | N_Formal_Modular_Type_Definition 722 | N_Formal_Ordinary_Fixed_Point_Definition 723 | N_Formal_Private_Type_Definition 724 | N_Formal_Incomplete_Type_Definition 725 | N_Formal_Signed_Integer_Type_Definition 726 | N_Function_Specification 727 | N_Generic_Association 728 | N_Index_Or_Discriminant_Constraint 729 | N_Iteration_Scheme 730 | N_Mod_Clause 731 | N_Modular_Type_Definition 732 | N_Ordinary_Fixed_Point_Definition 733 | N_Parameter_Specification 734 | N_Pragma_Argument_Association 735 | N_Procedure_Specification 736 | N_Real_Range_Specification 737 | N_Record_Definition 738 | N_Signed_Integer_Type_Definition 739 | N_Unconstrained_Array_Definition 740 | N_Unused_At_End 741 | N_Unused_At_Start 742 | N_Variant 743 => 744 raise Program_Error; 745 end case; 746 747 Debug_A_Exit ("analyzing ", N, " (done)"); 748 749 -- Mark relevant use-type and use-package clauses as effective 750 -- preferring the original node over the analyzed one in the case that 751 -- constant folding has occurred and removed references that need to be 752 -- examined. Also, if the node in question is overloaded then this is 753 -- deferred until resolution. 754 755 declare 756 Operat : Node_Id := Empty; 757 begin 758 -- Attempt to obtain a checkable operator node 759 760 if Nkind (Original_Node (N)) in N_Op then 761 Operat := Original_Node (N); 762 elsif Nkind (N) in N_Op then 763 Operat := N; 764 end if; 765 766 -- Mark the operator 767 768 if Present (Operat) 769 and then Present (Entity (Operat)) 770 and then not Is_Overloaded (Operat) 771 then 772 Mark_Use_Clauses (Operat); 773 end if; 774 end; 775 776 -- Now that we have analyzed the node, we call the expander to perform 777 -- possible expansion. We skip this for subexpressions, because we don't 778 -- have the type yet, and the expander will need to know the type before 779 -- it can do its job. For subexpression nodes, the call to the expander 780 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error, 781 -- which can appear in a statement context, and needs expanding now in 782 -- the case (distinguished by Etype, as documented in Sinfo). 783 784 -- The Analyzed flag is also set at this point for non-subexpression 785 -- nodes (in the case of subexpression nodes, we can't set the flag yet, 786 -- since resolution and expansion have not yet been completed). Note 787 -- that for N_Raise_xxx_Error we have to distinguish the expression 788 -- case from the statement case. 789 790 if Nkind (N) not in N_Subexpr 791 or else (Nkind (N) in N_Raise_xxx_Error 792 and then Etype (N) = Standard_Void_Type) 793 then 794 Expand (N); 795 796 -- Replace a reference to a renaming with the renamed object for SPARK. 797 -- In general this modification is performed by Expand_SPARK, however 798 -- certain constructs may not reach the resolution or expansion phase 799 -- and thus remain unchanged. The replacement is not performed when the 800 -- construct is overloaded as resolution must first take place. This is 801 -- also not done when analyzing a generic to preserve the original tree 802 -- and because the reference may become overloaded in the instance. 803 804 elsif GNATprove_Mode 805 and then Nkind_In (N, N_Expanded_Name, N_Identifier) 806 and then not Is_Overloaded (N) 807 and then not Inside_A_Generic 808 then 809 Expand_SPARK_Potential_Renaming (N); 810 end if; 811 812 Restore_Ghost_Mode (Saved_GM); 813 end Analyze; 814 815 -- Version with check(s) suppressed 816 817 procedure Analyze (N : Node_Id; Suppress : Check_Id) is 818 begin 819 if Suppress = All_Checks then 820 declare 821 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 822 begin 823 Scope_Suppress.Suppress := (others => True); 824 Analyze (N); 825 Scope_Suppress.Suppress := Svs; 826 end; 827 828 elsif Suppress = Overflow_Check then 829 declare 830 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 831 begin 832 Scope_Suppress.Suppress (Suppress) := True; 833 Analyze (N); 834 Scope_Suppress.Suppress (Suppress) := Svg; 835 end; 836 end if; 837 end Analyze; 838 839 ------------------ 840 -- Analyze_List -- 841 ------------------ 842 843 procedure Analyze_List (L : List_Id) is 844 Node : Node_Id; 845 846 begin 847 Node := First (L); 848 while Present (Node) loop 849 Analyze (Node); 850 Next (Node); 851 end loop; 852 end Analyze_List; 853 854 -- Version with check(s) suppressed 855 856 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is 857 begin 858 if Suppress = All_Checks then 859 declare 860 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 861 begin 862 Scope_Suppress.Suppress := (others => True); 863 Analyze_List (L); 864 Scope_Suppress.Suppress := Svs; 865 end; 866 867 else 868 declare 869 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 870 begin 871 Scope_Suppress.Suppress (Suppress) := True; 872 Analyze_List (L); 873 Scope_Suppress.Suppress (Suppress) := Svg; 874 end; 875 end if; 876 end Analyze_List; 877 878 -------------------------- 879 -- Copy_Suppress_Status -- 880 -------------------------- 881 882 procedure Copy_Suppress_Status 883 (C : Check_Id; 884 From : Entity_Id; 885 To : Entity_Id) 886 is 887 Found : Boolean; 888 pragma Warnings (Off, Found); 889 890 procedure Search_Stack 891 (Top : Suppress_Stack_Entry_Ptr; 892 Found : out Boolean); 893 -- Search given suppress stack for matching entry for entity. If found 894 -- then set Checks_May_Be_Suppressed on To, and push an appropriate 895 -- entry for To onto the local suppress stack. 896 897 ------------------ 898 -- Search_Stack -- 899 ------------------ 900 901 procedure Search_Stack 902 (Top : Suppress_Stack_Entry_Ptr; 903 Found : out Boolean) 904 is 905 Ptr : Suppress_Stack_Entry_Ptr; 906 907 begin 908 Ptr := Top; 909 while Ptr /= null loop 910 if Ptr.Entity = From 911 and then (Ptr.Check = All_Checks or else Ptr.Check = C) 912 then 913 if Ptr.Suppress then 914 Set_Checks_May_Be_Suppressed (To, True); 915 Push_Local_Suppress_Stack_Entry 916 (Entity => To, 917 Check => C, 918 Suppress => True); 919 Found := True; 920 return; 921 end if; 922 end if; 923 924 Ptr := Ptr.Prev; 925 end loop; 926 927 Found := False; 928 return; 929 end Search_Stack; 930 931 -- Start of processing for Copy_Suppress_Status 932 933 begin 934 if not Checks_May_Be_Suppressed (From) then 935 return; 936 end if; 937 938 -- First search the global entity suppress table for a matching entry. 939 -- We also search this in reverse order so that if there are multiple 940 -- pragmas for the same entity, the last one applies. 941 942 Search_Stack (Global_Suppress_Stack_Top, Found); 943 944 if Found then 945 return; 946 end if; 947 948 -- Now search the local entity suppress stack, we search this in 949 -- reverse order so that we get the innermost entry that applies to 950 -- this case if there are nested entries. Note that for the purpose 951 -- of this procedure we are ONLY looking for entries corresponding 952 -- to a two-argument Suppress, where the second argument matches From. 953 954 Search_Stack (Local_Suppress_Stack_Top, Found); 955 end Copy_Suppress_Status; 956 957 ------------------------- 958 -- Enter_Generic_Scope -- 959 ------------------------- 960 961 procedure Enter_Generic_Scope (S : Entity_Id) is 962 begin 963 if No (Outer_Generic_Scope) then 964 Outer_Generic_Scope := S; 965 end if; 966 end Enter_Generic_Scope; 967 968 ------------------------ 969 -- Exit_Generic_Scope -- 970 ------------------------ 971 972 procedure Exit_Generic_Scope (S : Entity_Id) is 973 begin 974 if S = Outer_Generic_Scope then 975 Outer_Generic_Scope := Empty; 976 end if; 977 end Exit_Generic_Scope; 978 979 ----------------------- 980 -- Explicit_Suppress -- 981 ----------------------- 982 983 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is 984 Ptr : Suppress_Stack_Entry_Ptr; 985 986 begin 987 if not Checks_May_Be_Suppressed (E) then 988 return False; 989 990 else 991 Ptr := Global_Suppress_Stack_Top; 992 while Ptr /= null loop 993 if Ptr.Entity = E 994 and then (Ptr.Check = All_Checks or else Ptr.Check = C) 995 then 996 return Ptr.Suppress; 997 end if; 998 999 Ptr := Ptr.Prev; 1000 end loop; 1001 end if; 1002 1003 return False; 1004 end Explicit_Suppress; 1005 1006 ----------------------------- 1007 -- External_Ref_In_Generic -- 1008 ----------------------------- 1009 1010 function External_Ref_In_Generic (E : Entity_Id) return Boolean is 1011 Scop : Entity_Id; 1012 1013 begin 1014 -- Entity is global if defined outside of current outer_generic_scope: 1015 -- Either the entity has a smaller depth that the outer generic, or it 1016 -- is in a different compilation unit, or it is defined within a unit 1017 -- in the same compilation, that is not within the outer_generic. 1018 1019 if No (Outer_Generic_Scope) then 1020 return False; 1021 1022 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) 1023 or else not In_Same_Source_Unit (E, Outer_Generic_Scope) 1024 then 1025 return True; 1026 1027 else 1028 Scop := Scope (E); 1029 while Present (Scop) loop 1030 if Scop = Outer_Generic_Scope then 1031 return False; 1032 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then 1033 return True; 1034 else 1035 Scop := Scope (Scop); 1036 end if; 1037 end loop; 1038 1039 return True; 1040 end if; 1041 end External_Ref_In_Generic; 1042 1043 ---------------- 1044 -- Initialize -- 1045 ---------------- 1046 1047 procedure Initialize is 1048 Next : Suppress_Stack_Entry_Ptr; 1049 1050 procedure Free is new Unchecked_Deallocation 1051 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr); 1052 1053 begin 1054 -- Free any global suppress stack entries from a previous invocation 1055 -- of the compiler (in the normal case this loop does nothing). 1056 1057 while Suppress_Stack_Entries /= null loop 1058 Next := Suppress_Stack_Entries.Next; 1059 Free (Suppress_Stack_Entries); 1060 Suppress_Stack_Entries := Next; 1061 end loop; 1062 1063 Local_Suppress_Stack_Top := null; 1064 Global_Suppress_Stack_Top := null; 1065 1066 -- Clear scope stack, and reset global variables 1067 1068 Scope_Stack.Init; 1069 Unloaded_Subunits := False; 1070 end Initialize; 1071 1072 ------------------------------ 1073 -- Insert_After_And_Analyze -- 1074 ------------------------------ 1075 1076 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is 1077 Node : Node_Id; 1078 1079 begin 1080 if Present (M) then 1081 1082 -- If we are not at the end of the list, then the easiest 1083 -- coding is simply to insert before our successor. 1084 1085 if Present (Next (N)) then 1086 Insert_Before_And_Analyze (Next (N), M); 1087 1088 -- Case of inserting at the end of the list 1089 1090 else 1091 -- Capture the Node_Id of the node to be inserted. This Node_Id 1092 -- will still be the same after the insert operation. 1093 1094 Node := M; 1095 Insert_After (N, M); 1096 1097 -- Now just analyze from the inserted node to the end of 1098 -- the new list (note that this properly handles the case 1099 -- where any of the analyze calls result in the insertion of 1100 -- nodes after the analyzed node, expecting analysis). 1101 1102 while Present (Node) loop 1103 Analyze (Node); 1104 Mark_Rewrite_Insertion (Node); 1105 Next (Node); 1106 end loop; 1107 end if; 1108 end if; 1109 end Insert_After_And_Analyze; 1110 1111 -- Version with check(s) suppressed 1112 1113 procedure Insert_After_And_Analyze 1114 (N : Node_Id; 1115 M : Node_Id; 1116 Suppress : Check_Id) 1117 is 1118 begin 1119 if Suppress = All_Checks then 1120 declare 1121 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 1122 begin 1123 Scope_Suppress.Suppress := (others => True); 1124 Insert_After_And_Analyze (N, M); 1125 Scope_Suppress.Suppress := Svs; 1126 end; 1127 1128 else 1129 declare 1130 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 1131 begin 1132 Scope_Suppress.Suppress (Suppress) := True; 1133 Insert_After_And_Analyze (N, M); 1134 Scope_Suppress.Suppress (Suppress) := Svg; 1135 end; 1136 end if; 1137 end Insert_After_And_Analyze; 1138 1139 ------------------------------- 1140 -- Insert_Before_And_Analyze -- 1141 ------------------------------- 1142 1143 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is 1144 Node : Node_Id; 1145 1146 begin 1147 if Present (M) then 1148 1149 -- Capture the Node_Id of the first list node to be inserted. 1150 -- This will still be the first node after the insert operation, 1151 -- since Insert_List_After does not modify the Node_Id values. 1152 1153 Node := M; 1154 Insert_Before (N, M); 1155 1156 -- The insertion does not change the Id's of any of the nodes in 1157 -- the list, and they are still linked, so we can simply loop from 1158 -- the original first node until we meet the node before which the 1159 -- insertion is occurring. Note that this properly handles the case 1160 -- where any of the analyzed nodes insert nodes after themselves, 1161 -- expecting them to get analyzed. 1162 1163 while Node /= N loop 1164 Analyze (Node); 1165 Mark_Rewrite_Insertion (Node); 1166 Next (Node); 1167 end loop; 1168 end if; 1169 end Insert_Before_And_Analyze; 1170 1171 -- Version with check(s) suppressed 1172 1173 procedure Insert_Before_And_Analyze 1174 (N : Node_Id; 1175 M : Node_Id; 1176 Suppress : Check_Id) 1177 is 1178 begin 1179 if Suppress = All_Checks then 1180 declare 1181 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 1182 begin 1183 Scope_Suppress.Suppress := (others => True); 1184 Insert_Before_And_Analyze (N, M); 1185 Scope_Suppress.Suppress := Svs; 1186 end; 1187 1188 else 1189 declare 1190 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 1191 begin 1192 Scope_Suppress.Suppress (Suppress) := True; 1193 Insert_Before_And_Analyze (N, M); 1194 Scope_Suppress.Suppress (Suppress) := Svg; 1195 end; 1196 end if; 1197 end Insert_Before_And_Analyze; 1198 1199 ----------------------------------- 1200 -- Insert_List_After_And_Analyze -- 1201 ----------------------------------- 1202 1203 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is 1204 After : constant Node_Id := Next (N); 1205 Node : Node_Id; 1206 1207 begin 1208 if Is_Non_Empty_List (L) then 1209 1210 -- Capture the Node_Id of the first list node to be inserted. 1211 -- This will still be the first node after the insert operation, 1212 -- since Insert_List_After does not modify the Node_Id values. 1213 1214 Node := First (L); 1215 Insert_List_After (N, L); 1216 1217 -- Now just analyze from the original first node until we get to the 1218 -- successor of the original insertion point (which may be Empty if 1219 -- the insertion point was at the end of the list). Note that this 1220 -- properly handles the case where any of the analyze calls result in 1221 -- the insertion of nodes after the analyzed node (possibly calling 1222 -- this routine recursively). 1223 1224 while Node /= After loop 1225 Analyze (Node); 1226 Mark_Rewrite_Insertion (Node); 1227 Next (Node); 1228 end loop; 1229 end if; 1230 end Insert_List_After_And_Analyze; 1231 1232 ------------------------------------ 1233 -- Insert_List_Before_And_Analyze -- 1234 ------------------------------------ 1235 1236 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is 1237 Node : Node_Id; 1238 1239 begin 1240 if Is_Non_Empty_List (L) then 1241 1242 -- Capture the Node_Id of the first list node to be inserted. This 1243 -- will still be the first node after the insert operation, since 1244 -- Insert_List_After does not modify the Node_Id values. 1245 1246 Node := First (L); 1247 Insert_List_Before (N, L); 1248 1249 -- The insertion does not change the Id's of any of the nodes in 1250 -- the list, and they are still linked, so we can simply loop from 1251 -- the original first node until we meet the node before which the 1252 -- insertion is occurring. Note that this properly handles the case 1253 -- where any of the analyzed nodes insert nodes after themselves, 1254 -- expecting them to get analyzed. 1255 1256 while Node /= N loop 1257 Analyze (Node); 1258 Mark_Rewrite_Insertion (Node); 1259 Next (Node); 1260 end loop; 1261 end if; 1262 end Insert_List_Before_And_Analyze; 1263 1264 ---------- 1265 -- Lock -- 1266 ---------- 1267 1268 procedure Lock is 1269 begin 1270 Scope_Stack.Release; 1271 Scope_Stack.Locked := True; 1272 end Lock; 1273 1274 ------------------------ 1275 -- Preanalysis_Active -- 1276 ------------------------ 1277 1278 function Preanalysis_Active return Boolean is 1279 begin 1280 return not Full_Analysis and not Expander_Active; 1281 end Preanalysis_Active; 1282 1283 ---------------- 1284 -- Preanalyze -- 1285 ---------------- 1286 1287 procedure Preanalyze (N : Node_Id) is 1288 Save_Full_Analysis : constant Boolean := Full_Analysis; 1289 1290 begin 1291 Full_Analysis := False; 1292 Expander_Mode_Save_And_Set (False); 1293 1294 Analyze (N); 1295 1296 Expander_Mode_Restore; 1297 Full_Analysis := Save_Full_Analysis; 1298 end Preanalyze; 1299 1300 -------------------------------------- 1301 -- Push_Global_Suppress_Stack_Entry -- 1302 -------------------------------------- 1303 1304 procedure Push_Global_Suppress_Stack_Entry 1305 (Entity : Entity_Id; 1306 Check : Check_Id; 1307 Suppress : Boolean) 1308 is 1309 begin 1310 Global_Suppress_Stack_Top := 1311 new Suppress_Stack_Entry' 1312 (Entity => Entity, 1313 Check => Check, 1314 Suppress => Suppress, 1315 Prev => Global_Suppress_Stack_Top, 1316 Next => Suppress_Stack_Entries); 1317 Suppress_Stack_Entries := Global_Suppress_Stack_Top; 1318 return; 1319 end Push_Global_Suppress_Stack_Entry; 1320 1321 ------------------------------------- 1322 -- Push_Local_Suppress_Stack_Entry -- 1323 ------------------------------------- 1324 1325 procedure Push_Local_Suppress_Stack_Entry 1326 (Entity : Entity_Id; 1327 Check : Check_Id; 1328 Suppress : Boolean) 1329 is 1330 begin 1331 Local_Suppress_Stack_Top := 1332 new Suppress_Stack_Entry' 1333 (Entity => Entity, 1334 Check => Check, 1335 Suppress => Suppress, 1336 Prev => Local_Suppress_Stack_Top, 1337 Next => Suppress_Stack_Entries); 1338 Suppress_Stack_Entries := Local_Suppress_Stack_Top; 1339 1340 return; 1341 end Push_Local_Suppress_Stack_Entry; 1342 1343 --------------- 1344 -- Semantics -- 1345 --------------- 1346 1347 procedure Semantics (Comp_Unit : Node_Id) is 1348 procedure Do_Analyze; 1349 -- Perform the analysis of the compilation unit 1350 1351 ---------------- 1352 -- Do_Analyze -- 1353 ---------------- 1354 1355 -- WARNING: This routine manages Ghost regions. Return statements must 1356 -- be replaced by gotos which jump to the end of the routine and restore 1357 -- the Ghost mode. 1358 1359 procedure Do_Analyze is 1360 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 1361 1362 -- Generally style checks are preserved across compilations, with 1363 -- one exception: s-oscons.ads, which allows arbitrary long lines 1364 -- unconditionally, and has no restore mechanism, because it is 1365 -- intended as a lowest-level Pure package. 1366 1367 Save_Max_Line : constant Int := Style_Max_Line_Length; 1368 1369 List : Elist_Id; 1370 1371 begin 1372 List := Save_Scope_Stack; 1373 Push_Scope (Standard_Standard); 1374 1375 -- Set up a clean environment before analyzing 1376 1377 Install_Ghost_Mode (None); 1378 Outer_Generic_Scope := Empty; 1379 Scope_Suppress := Suppress_Options; 1380 Scope_Stack.Table 1381 (Scope_Stack.Last).Component_Alignment_Default := 1382 Configuration_Component_Alignment; 1383 Scope_Stack.Table 1384 (Scope_Stack.Last).Is_Active_Stack_Base := True; 1385 1386 -- Now analyze the top level compilation unit node 1387 1388 Analyze (Comp_Unit); 1389 1390 -- Check for scope mismatch on exit from compilation 1391 1392 pragma Assert (Current_Scope = Standard_Standard 1393 or else Comp_Unit = Cunit (Main_Unit)); 1394 1395 -- Then pop entry for Standard, and pop implicit types 1396 1397 Pop_Scope; 1398 Restore_Scope_Stack (List); 1399 Restore_Ghost_Mode (Save_Ghost_Mode); 1400 Style_Max_Line_Length := Save_Max_Line; 1401 end Do_Analyze; 1402 1403 -- Local variables 1404 1405 -- The following locations save the corresponding global flags and 1406 -- variables so that they can be restored on completion. This is needed 1407 -- so that calls to Rtsfind start with the proper default values for 1408 -- these variables, and also that such calls do not disturb the settings 1409 -- for units being analyzed at a higher level. 1410 1411 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; 1412 S_Full_Analysis : constant Boolean := Full_Analysis; 1413 S_GNAT_Mode : constant Boolean := GNAT_Mode; 1414 S_Global_Dis_Names : constant Boolean := Global_Discard_Names; 1415 S_In_Assertion_Expr : constant Nat := In_Assertion_Expr; 1416 S_In_Default_Expr : constant Boolean := In_Default_Expr; 1417 S_In_Spec_Expr : constant Boolean := In_Spec_Expression; 1418 S_Inside_A_Generic : constant Boolean := Inside_A_Generic; 1419 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; 1420 S_Style_Check : constant Boolean := Style_Check; 1421 1422 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit); 1423 1424 Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit); 1425 -- New value of Current_Sem_Unit 1426 1427 Generic_Main : constant Boolean := 1428 Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration; 1429 -- If the main unit is generic, every compiled unit, including its 1430 -- context, is compiled with expansion disabled. 1431 1432 Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean := 1433 Curunit = Main_Unit 1434 or else 1435 (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body 1436 and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit)); 1437 -- Configuration flags have special settings when compiling a predefined 1438 -- file as a main unit. This applies to its spec as well. 1439 1440 Ext_Main_Source_Unit : constant Boolean := 1441 In_Extended_Main_Source_Unit (Comp_Unit); 1442 -- Determine if unit is in extended main source unit 1443 1444 Save_Config_Switches : Config_Switches_Type; 1445 -- Variable used to save values of config switches while we analyze the 1446 -- new unit, to be restored on exit for proper recursive behavior. 1447 1448 Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions; 1449 -- Used to save non-partition wide restrictions before processing new 1450 -- unit. All with'ed units are analyzed with config restrictions reset 1451 -- and we need to restore these saved values at the end. 1452 1453 -- Start of processing for Semantics 1454 1455 begin 1456 if Debug_Unit_Walk then 1457 if Already_Analyzed then 1458 Write_Str ("(done)"); 1459 end if; 1460 1461 Write_Unit_Info 1462 (Get_Cunit_Unit_Number (Comp_Unit), 1463 Unit (Comp_Unit), 1464 Prefix => "--> "); 1465 Indent; 1466 end if; 1467 1468 Compiler_State := Analyzing; 1469 Current_Sem_Unit := Curunit; 1470 1471 -- Compile predefined units with GNAT_Mode set to True, to properly 1472 -- process the categorization stuff. However, do not set GNAT_Mode 1473 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO, 1474 -- Sequential_IO) as this would prevent pragma Extend_System from being 1475 -- taken into account, for example when Text_IO is renaming DEC.Text_IO. 1476 1477 if Is_Predefined_Unit (Current_Sem_Unit) 1478 and then not Is_Predefined_Renaming (Current_Sem_Unit) 1479 then 1480 GNAT_Mode := True; 1481 end if; 1482 1483 -- For generic main, never do expansion 1484 1485 if Generic_Main then 1486 Expander_Mode_Save_And_Set (False); 1487 1488 -- Non generic case 1489 1490 else 1491 Expander_Mode_Save_And_Set 1492 1493 -- Turn on expansion if generating code 1494 1495 (Operating_Mode = Generate_Code 1496 1497 -- Or if special debug flag -gnatdx is set 1498 1499 or else Debug_Flag_X 1500 1501 -- Or if in configuration run-time mode. We do this so we get 1502 -- error messages about missing entities in the run-time even 1503 -- if we are compiling in -gnatc (no code generation) mode. 1504 -- Similar processing applies to No_Run_Time_Mode. However, 1505 -- don't do this if debug flag -gnatd.Z is set or when we are 1506 -- compiling a separate unit (this is to handle a situation 1507 -- where this new processing causes trouble). 1508 1509 or else 1510 ((Configurable_Run_Time_Mode or No_Run_Time_Mode) 1511 and then not Debug_Flag_Dot_ZZ 1512 and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit)); 1513 end if; 1514 1515 Full_Analysis := True; 1516 Inside_A_Generic := False; 1517 In_Assertion_Expr := 0; 1518 In_Default_Expr := False; 1519 In_Spec_Expression := False; 1520 Set_Comes_From_Source_Default (False); 1521 1522 -- Save current config switches and reset then appropriately 1523 1524 Save_Opt_Config_Switches (Save_Config_Switches); 1525 Set_Opt_Config_Switches 1526 (Is_Internal_Unit (Current_Sem_Unit), 1527 Is_Main_Unit_Or_Main_Unit_Spec); 1528 1529 -- Save current non-partition-wide restrictions 1530 1531 Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save; 1532 1533 -- For unit in main extended unit, we reset the configuration values 1534 -- for the non-partition-wide restrictions. For other units reset them. 1535 1536 if Ext_Main_Source_Unit then 1537 Restore_Config_Cunit_Boolean_Restrictions; 1538 else 1539 Reset_Cunit_Boolean_Restrictions; 1540 end if; 1541 1542 -- Turn off style checks for unit that is not in the extended main 1543 -- source unit. This improves processing efficiency for such units 1544 -- (for which we don't want style checks anyway, and where they will 1545 -- get suppressed), and is definitely needed to stop some style checks 1546 -- from invading the run-time units (e.g. overriding checks). 1547 1548 if not Ext_Main_Source_Unit then 1549 Style_Check := False; 1550 1551 -- If this is part of the extended main source unit, set style check 1552 -- mode to match the style check mode of the main source unit itself. 1553 1554 else 1555 Style_Check := Style_Check_Main; 1556 end if; 1557 1558 -- Only do analysis of unit that has not already been analyzed 1559 1560 if not Analyzed (Comp_Unit) then 1561 Initialize_Version (Current_Sem_Unit); 1562 1563 -- Do analysis, and then append the compilation unit onto the 1564 -- Comp_Unit_List, if appropriate. This is done after analysis, 1565 -- so if this unit depends on some others, they have already been 1566 -- appended. We ignore bodies, except for the main unit itself, and 1567 -- for subprogram bodies that act as specs. We have also to guard 1568 -- against ill-formed subunits that have an improper context. 1569 1570 Do_Analyze; 1571 1572 if Present (Comp_Unit) 1573 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body 1574 and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body 1575 or else not Acts_As_Spec (Comp_Unit)) 1576 and then not In_Extended_Main_Source_Unit (Comp_Unit) 1577 then 1578 null; 1579 1580 else 1581 Append_New_Elmt (Comp_Unit, To => Comp_Unit_List); 1582 1583 if Debug_Unit_Walk then 1584 Write_Str ("Appending "); 1585 Write_Unit_Info 1586 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit)); 1587 end if; 1588 end if; 1589 end if; 1590 1591 -- Save indication of dynamic elaboration checks for ALI file 1592 1593 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks); 1594 1595 -- Restore settings of saved switches to entry values 1596 1597 Current_Sem_Unit := S_Current_Sem_Unit; 1598 Full_Analysis := S_Full_Analysis; 1599 Global_Discard_Names := S_Global_Dis_Names; 1600 GNAT_Mode := S_GNAT_Mode; 1601 In_Assertion_Expr := S_In_Assertion_Expr; 1602 In_Default_Expr := S_In_Default_Expr; 1603 In_Spec_Expression := S_In_Spec_Expr; 1604 Inside_A_Generic := S_Inside_A_Generic; 1605 Outer_Generic_Scope := S_Outer_Gen_Scope; 1606 Style_Check := S_Style_Check; 1607 1608 Restore_Opt_Config_Switches (Save_Config_Switches); 1609 1610 -- Deal with restore of restrictions 1611 1612 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions); 1613 1614 Expander_Mode_Restore; 1615 1616 if Debug_Unit_Walk then 1617 Outdent; 1618 1619 if Already_Analyzed then 1620 Write_Str ("(done)"); 1621 end if; 1622 1623 Write_Unit_Info 1624 (Get_Cunit_Unit_Number (Comp_Unit), 1625 Unit (Comp_Unit), 1626 Prefix => "<-- "); 1627 end if; 1628 end Semantics; 1629 1630 -------- 1631 -- ss -- 1632 -------- 1633 1634 function ss (Index : Int) return Scope_Stack_Entry is 1635 begin 1636 return Scope_Stack.Table (Index); 1637 end ss; 1638 1639 --------- 1640 -- sst -- 1641 --------- 1642 1643 function sst return Scope_Stack_Entry is 1644 begin 1645 return ss (Scope_Stack.Last); 1646 end sst; 1647 1648 ------------ 1649 -- Unlock -- 1650 ------------ 1651 1652 procedure Unlock is 1653 begin 1654 Scope_Stack.Locked := False; 1655 end Unlock; 1656 1657 ------------------------ 1658 -- Walk_Library_Items -- 1659 ------------------------ 1660 1661 procedure Walk_Library_Items is 1662 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 1663 pragma Pack (Unit_Number_Set); 1664 1665 Main_CU : constant Node_Id := Cunit (Main_Unit); 1666 1667 Seen, Done : Unit_Number_Set := (others => False); 1668 -- Seen (X) is True after we have seen unit X in the walk. This is used 1669 -- to prevent processing the same unit more than once. Done (X) is True 1670 -- after we have fully processed X, and is used only for debugging 1671 -- printouts and assertions. 1672 1673 Do_Main : Boolean := False; 1674 -- Flag to delay processing the main body until after all other units. 1675 -- This is needed because the spec of the main unit may appear in the 1676 -- context of some other unit. We do not want this to force processing 1677 -- of the main body before all other units have been processed. 1678 -- 1679 -- Another circularity pattern occurs when the main unit is a child unit 1680 -- and the body of an ancestor has a with-clause of the main unit or on 1681 -- one of its children. In both cases the body in question has a with- 1682 -- clause on the main unit, and must be excluded from the traversal. In 1683 -- some convoluted cases this may lead to a CodePeer error because the 1684 -- spec of a subprogram declared in an instance within the parent will 1685 -- not be seen in the main unit. 1686 1687 function Depends_On_Main (CU : Node_Id) return Boolean; 1688 -- The body of a unit that is withed by the spec of the main unit may in 1689 -- turn have a with_clause on that spec. In that case do not traverse 1690 -- the body, to prevent loops. It can also happen that the main body has 1691 -- a with_clause on a child, which of course has an implicit with on its 1692 -- parent. It's OK to traverse the child body if the main spec has been 1693 -- processed, otherwise we also have a circularity to avoid. 1694 1695 procedure Do_Action (CU : Node_Id; Item : Node_Id); 1696 -- Calls Action, with some validity checks 1697 1698 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id); 1699 -- Calls Do_Action, first on the units with'ed by this one, then on 1700 -- this unit. If it's an instance body, do the spec first. If it is 1701 -- an instance spec, do the body last. 1702 1703 procedure Do_Withed_Unit (Withed_Unit : Node_Id); 1704 -- Apply Do_Unit_And_Dependents to a unit in a context clause 1705 1706 procedure Process_Bodies_In_Context (Comp : Node_Id); 1707 -- The main unit and its spec may depend on bodies that contain generics 1708 -- that are instantiated in them. Iterate through the corresponding 1709 -- contexts before processing main (spec/body) itself, to process bodies 1710 -- that may be present, together with their context. The spec of main 1711 -- is processed wherever it appears in the list of units, while the body 1712 -- is processed as the last unit in the list. 1713 1714 --------------------- 1715 -- Depends_On_Main -- 1716 --------------------- 1717 1718 function Depends_On_Main (CU : Node_Id) return Boolean is 1719 CL : Node_Id; 1720 MCU : constant Node_Id := Unit (Main_CU); 1721 1722 begin 1723 CL := First (Context_Items (CU)); 1724 1725 -- Problem does not arise with main subprograms 1726 1727 if 1728 not Nkind_In (MCU, N_Package_Body, N_Package_Declaration) 1729 then 1730 return False; 1731 end if; 1732 1733 while Present (CL) loop 1734 if Nkind (CL) = N_With_Clause 1735 and then Library_Unit (CL) = Main_CU 1736 and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) 1737 then 1738 return True; 1739 end if; 1740 1741 Next (CL); 1742 end loop; 1743 1744 return False; 1745 end Depends_On_Main; 1746 1747 --------------- 1748 -- Do_Action -- 1749 --------------- 1750 1751 procedure Do_Action (CU : Node_Id; Item : Node_Id) is 1752 begin 1753 -- This calls Action at the end. All the preceding code is just 1754 -- assertions and debugging output. 1755 1756 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit); 1757 1758 case Nkind (Item) is 1759 when N_Generic_Function_Renaming_Declaration 1760 | N_Generic_Package_Declaration 1761 | N_Generic_Package_Renaming_Declaration 1762 | N_Generic_Procedure_Renaming_Declaration 1763 | N_Generic_Subprogram_Declaration 1764 | N_Package_Declaration 1765 | N_Package_Renaming_Declaration 1766 | N_Subprogram_Declaration 1767 | N_Subprogram_Renaming_Declaration 1768 => 1769 -- Specs are OK 1770 1771 null; 1772 1773 when N_Package_Body => 1774 1775 -- Package bodies are processed separately if the main unit 1776 -- depends on them. 1777 1778 null; 1779 1780 when N_Subprogram_Body => 1781 1782 -- A subprogram body must be the main unit 1783 1784 pragma Assert (Acts_As_Spec (CU) 1785 or else CU = Cunit (Main_Unit)); 1786 null; 1787 1788 when N_Function_Instantiation 1789 | N_Package_Instantiation 1790 | N_Procedure_Instantiation 1791 => 1792 -- Can only happen if some generic body (needed for gnat2scil 1793 -- traversal, but not by GNAT) is not available, ignore. 1794 1795 null; 1796 1797 -- All other cases cannot happen 1798 1799 when N_Subunit => 1800 pragma Assert (False, "subunit"); 1801 null; 1802 1803 when N_Null_Statement => 1804 1805 -- Do not call Action for an ignored ghost unit 1806 1807 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (Item))); 1808 return; 1809 1810 when others => 1811 pragma Assert (False); 1812 null; 1813 end case; 1814 1815 if Present (CU) then 1816 pragma Assert (Item /= Stand.Standard_Package_Node); 1817 pragma Assert (Item = Unit (CU)); 1818 1819 declare 1820 Unit_Num : constant Unit_Number_Type := 1821 Get_Cunit_Unit_Number (CU); 1822 1823 procedure Assert_Done (Withed_Unit : Node_Id); 1824 -- Assert Withed_Unit is already Done, unless it's a body. It 1825 -- might seem strange for a with_clause to refer to a body, but 1826 -- this happens in the case of a generic instantiation, which 1827 -- gets transformed into the instance body (and the instance 1828 -- spec is also created). With clauses pointing to the 1829 -- instantiation end up pointing to the instance body. 1830 1831 ----------------- 1832 -- Assert_Done -- 1833 ----------------- 1834 1835 procedure Assert_Done (Withed_Unit : Node_Id) is 1836 begin 1837 if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then 1838 if not Nkind_In 1839 (Unit (Withed_Unit), 1840 N_Generic_Package_Declaration, 1841 N_Package_Body, 1842 N_Package_Renaming_Declaration, 1843 N_Subprogram_Body) 1844 then 1845 Write_Unit_Name 1846 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit))); 1847 Write_Str (" not yet walked!"); 1848 1849 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then 1850 Write_Str (" (self-ref)"); 1851 end if; 1852 1853 Write_Eol; 1854 1855 pragma Assert (False); 1856 end if; 1857 end if; 1858 end Assert_Done; 1859 1860 procedure Assert_Withed_Units_Done is 1861 new Walk_Withs (Assert_Done); 1862 1863 begin 1864 if Debug_Unit_Walk then 1865 Write_Unit_Info (Unit_Num, Item, Withs => True); 1866 end if; 1867 1868 -- Main unit should come last, except in the case where we 1869 -- skipped System_Aux_Id, in which case we missed the things it 1870 -- depends on, and in the case of parent bodies if present. 1871 1872 pragma Assert 1873 (not Done (Main_Unit) 1874 or else Present (System_Aux_Id) 1875 or else Nkind (Item) = N_Package_Body); 1876 1877 -- We shouldn't do the same thing twice 1878 1879 pragma Assert (not Done (Unit_Num)); 1880 1881 -- Everything we depend upon should already be done 1882 1883 pragma Debug 1884 (Assert_Withed_Units_Done (CU, Include_Limited => False)); 1885 end; 1886 1887 else 1888 -- Must be Standard, which has no entry in the units table 1889 1890 pragma Assert (Item = Stand.Standard_Package_Node); 1891 1892 if Debug_Unit_Walk then 1893 Write_Line ("Standard"); 1894 end if; 1895 end if; 1896 1897 Action (Item); 1898 end Do_Action; 1899 1900 -------------------- 1901 -- Do_Withed_Unit -- 1902 -------------------- 1903 1904 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is 1905 begin 1906 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); 1907 1908 -- If the unit in the with_clause is a generic instance, the clause 1909 -- now denotes the instance body. Traverse the corresponding spec 1910 -- because there may be no other dependence that will force the 1911 -- traversal of its own context. 1912 1913 if Nkind (Unit (Withed_Unit)) = N_Package_Body 1914 and then Is_Generic_Instance 1915 (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) 1916 then 1917 Do_Withed_Unit (Library_Unit (Withed_Unit)); 1918 end if; 1919 end Do_Withed_Unit; 1920 1921 ---------------------------- 1922 -- Do_Unit_And_Dependents -- 1923 ---------------------------- 1924 1925 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is 1926 Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); 1927 Child : Node_Id; 1928 Body_U : Unit_Number_Type; 1929 Parent_CU : Node_Id; 1930 1931 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); 1932 1933 begin 1934 if not Seen (Unit_Num) then 1935 1936 -- Process the with clauses 1937 1938 Do_Withed_Units (CU, Include_Limited => False); 1939 1940 -- Process the unit if it is a spec or the main unit, if it 1941 -- has no previous spec or we have done all other units. 1942 1943 if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) 1944 or else Acts_As_Spec (CU) 1945 then 1946 if CU = Cunit (Main_Unit) 1947 and then not Do_Main 1948 then 1949 Seen (Unit_Num) := False; 1950 1951 else 1952 Seen (Unit_Num) := True; 1953 1954 if CU = Library_Unit (Main_CU) then 1955 Process_Bodies_In_Context (CU); 1956 1957 -- If main is a child unit, examine parent unit contexts 1958 -- to see if they include instantiated units. Also, if 1959 -- the parent itself is an instance, process its body 1960 -- because it may contain subprograms that are called 1961 -- in the main unit. 1962 1963 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then 1964 Child := Cunit_Entity (Main_Unit); 1965 while Is_Child_Unit (Child) loop 1966 Parent_CU := 1967 Cunit 1968 (Get_Cunit_Entity_Unit_Number (Scope (Child))); 1969 Process_Bodies_In_Context (Parent_CU); 1970 1971 if Nkind (Unit (Parent_CU)) = N_Package_Body 1972 and then 1973 Nkind (Original_Node (Unit (Parent_CU))) 1974 = N_Package_Instantiation 1975 and then 1976 not Seen (Get_Cunit_Unit_Number (Parent_CU)) 1977 then 1978 Body_U := Get_Cunit_Unit_Number (Parent_CU); 1979 Seen (Body_U) := True; 1980 Do_Action (Parent_CU, Unit (Parent_CU)); 1981 Done (Body_U) := True; 1982 end if; 1983 1984 Child := Scope (Child); 1985 end loop; 1986 end if; 1987 end if; 1988 1989 Do_Action (CU, Item); 1990 Done (Unit_Num) := True; 1991 end if; 1992 end if; 1993 end if; 1994 end Do_Unit_And_Dependents; 1995 1996 ------------------------------- 1997 -- Process_Bodies_In_Context -- 1998 ------------------------------- 1999 2000 procedure Process_Bodies_In_Context (Comp : Node_Id) is 2001 Body_CU : Node_Id; 2002 Body_U : Unit_Number_Type; 2003 Clause : Node_Id; 2004 Spec : Node_Id; 2005 2006 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); 2007 2008 -- Start of processing for Process_Bodies_In_Context 2009 2010 begin 2011 Clause := First (Context_Items (Comp)); 2012 while Present (Clause) loop 2013 if Nkind (Clause) = N_With_Clause then 2014 Spec := Library_Unit (Clause); 2015 Body_CU := Library_Unit (Spec); 2016 2017 -- If we are processing the spec of the main unit, load bodies 2018 -- only if the with_clause indicates that it forced the loading 2019 -- of the body for a generic instantiation. Note that bodies of 2020 -- parents that are instances have been loaded already. 2021 2022 if Present (Body_CU) 2023 and then Body_CU /= Cunit (Main_Unit) 2024 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body 2025 and then (Nkind (Unit (Comp)) /= N_Package_Declaration 2026 or else Present (Withed_Body (Clause))) 2027 then 2028 Body_U := Get_Cunit_Unit_Number (Body_CU); 2029 2030 if not Seen (Body_U) 2031 and then not Depends_On_Main (Body_CU) 2032 then 2033 Seen (Body_U) := True; 2034 Do_Withed_Units (Body_CU, Include_Limited => False); 2035 Do_Action (Body_CU, Unit (Body_CU)); 2036 Done (Body_U) := True; 2037 end if; 2038 end if; 2039 end if; 2040 2041 Next (Clause); 2042 end loop; 2043 end Process_Bodies_In_Context; 2044 2045 -- Local Declarations 2046 2047 Cur : Elmt_Id; 2048 2049 -- Start of processing for Walk_Library_Items 2050 2051 begin 2052 if Debug_Unit_Walk then 2053 Write_Line ("Walk_Library_Items:"); 2054 Indent; 2055 end if; 2056 2057 -- Do Standard first, then walk the Comp_Unit_List 2058 2059 Do_Action (Empty, Standard_Package_Node); 2060 2061 -- First place the context of all instance bodies on the corresponding 2062 -- spec, because it may be needed to analyze the code at the place of 2063 -- the instantiation. 2064 2065 Cur := First_Elmt (Comp_Unit_List); 2066 while Present (Cur) loop 2067 declare 2068 CU : constant Node_Id := Node (Cur); 2069 N : constant Node_Id := Unit (CU); 2070 2071 begin 2072 if Nkind (N) = N_Package_Body 2073 and then Is_Generic_Instance (Defining_Entity (N)) 2074 then 2075 Append_List 2076 (Context_Items (CU), Context_Items (Library_Unit (CU))); 2077 end if; 2078 2079 Next_Elmt (Cur); 2080 end; 2081 end loop; 2082 2083 -- Now traverse compilation units (specs) in order 2084 2085 Cur := First_Elmt (Comp_Unit_List); 2086 while Present (Cur) loop 2087 declare 2088 CU : constant Node_Id := Node (Cur); 2089 N : constant Node_Id := Unit (CU); 2090 Par : Entity_Id; 2091 2092 begin 2093 pragma Assert (Nkind (CU) = N_Compilation_Unit); 2094 2095 case Nkind (N) is 2096 2097 -- If it is a subprogram body, process it if it has no 2098 -- separate spec. 2099 2100 -- If it's a package body, ignore it, unless it is a body 2101 -- created for an instance that is the main unit. In the case 2102 -- of subprograms, the body is the wrapper package. In case of 2103 -- a package, the original file carries the body, and the spec 2104 -- appears as a later entry in the units list. 2105 2106 -- Otherwise bodies appear in the list only because of inlining 2107 -- or instantiations, and they are processed only if relevant. 2108 -- The flag Withed_Body on a context clause indicates that a 2109 -- unit contains an instantiation that may be needed later, 2110 -- and therefore the body that contains the generic body (and 2111 -- its context) must be traversed immediately after the 2112 -- corresponding spec (see Do_Unit_And_Dependents). 2113 2114 -- The main unit itself is processed separately after all other 2115 -- specs, and relevant bodies are examined in Process_Main. 2116 2117 when N_Subprogram_Body => 2118 if Acts_As_Spec (N) then 2119 Do_Unit_And_Dependents (CU, N); 2120 end if; 2121 2122 when N_Package_Body => 2123 if CU = Main_CU 2124 and then Nkind (Original_Node (Unit (Main_CU))) in 2125 N_Generic_Instantiation 2126 and then Present (Library_Unit (Main_CU)) 2127 then 2128 Do_Unit_And_Dependents 2129 (Library_Unit (Main_CU), 2130 Unit (Library_Unit (Main_CU))); 2131 end if; 2132 2133 -- It is a spec, process it, and the units it depends on, 2134 -- unless it is a descendant of the main unit. This can happen 2135 -- when the body of a parent depends on some other descendant. 2136 2137 when N_Null_Statement => 2138 2139 -- Ignore an ignored ghost unit 2140 2141 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (N))); 2142 null; 2143 2144 when others => 2145 Par := Scope (Defining_Entity (Unit (CU))); 2146 2147 if Is_Child_Unit (Defining_Entity (Unit (CU))) then 2148 while Present (Par) 2149 and then Par /= Standard_Standard 2150 and then Par /= Cunit_Entity (Main_Unit) 2151 loop 2152 Par := Scope (Par); 2153 end loop; 2154 end if; 2155 2156 if Par /= Cunit_Entity (Main_Unit) then 2157 Do_Unit_And_Dependents (CU, N); 2158 end if; 2159 end case; 2160 end; 2161 2162 Next_Elmt (Cur); 2163 end loop; 2164 2165 -- Now process package bodies on which main depends, followed by bodies 2166 -- of parents, if present, and finally main itself. 2167 2168 if not Done (Main_Unit) then 2169 Do_Main := True; 2170 2171 Process_Main : declare 2172 Parent_CU : Node_Id; 2173 Body_CU : Node_Id; 2174 Body_U : Unit_Number_Type; 2175 Child : Entity_Id; 2176 2177 function Is_Subunit_Of_Main (U : Node_Id) return Boolean; 2178 -- If the main unit has subunits, their context may include 2179 -- bodies that are needed in the body of main. We must examine 2180 -- the context of the subunits, which are otherwise not made 2181 -- explicit in the main unit. 2182 2183 ------------------------ 2184 -- Is_Subunit_Of_Main -- 2185 ------------------------ 2186 2187 function Is_Subunit_Of_Main (U : Node_Id) return Boolean is 2188 Lib : Node_Id; 2189 begin 2190 if No (U) then 2191 return False; 2192 else 2193 Lib := Library_Unit (U); 2194 return Nkind (Unit (U)) = N_Subunit 2195 and then 2196 (Lib = Cunit (Main_Unit) 2197 or else Is_Subunit_Of_Main (Lib)); 2198 end if; 2199 end Is_Subunit_Of_Main; 2200 2201 -- Start of processing for Process_Main 2202 2203 begin 2204 Process_Bodies_In_Context (Main_CU); 2205 2206 for Unit_Num in Done'Range loop 2207 if Is_Subunit_Of_Main (Cunit (Unit_Num)) then 2208 Process_Bodies_In_Context (Cunit (Unit_Num)); 2209 end if; 2210 end loop; 2211 2212 -- If the main unit is a child unit, parent bodies may be present 2213 -- because they export instances or inlined subprograms. Check for 2214 -- presence of these, which are not present in context clauses. 2215 -- Note that if the parents are instances, their bodies have been 2216 -- processed before the main spec, because they may be needed 2217 -- therein, so the following loop only affects non-instances. 2218 2219 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then 2220 Child := Cunit_Entity (Main_Unit); 2221 while Is_Child_Unit (Child) loop 2222 Parent_CU := 2223 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); 2224 Body_CU := Library_Unit (Parent_CU); 2225 2226 if Present (Body_CU) 2227 and then not Seen (Get_Cunit_Unit_Number (Body_CU)) 2228 and then not Depends_On_Main (Body_CU) 2229 then 2230 Body_U := Get_Cunit_Unit_Number (Body_CU); 2231 Seen (Body_U) := True; 2232 Do_Action (Body_CU, Unit (Body_CU)); 2233 Done (Body_U) := True; 2234 end if; 2235 2236 Child := Scope (Child); 2237 end loop; 2238 end if; 2239 2240 Do_Action (Main_CU, Unit (Main_CU)); 2241 Done (Main_Unit) := True; 2242 end Process_Main; 2243 end if; 2244 2245 if Debug_Unit_Walk then 2246 if Done /= (Done'Range => True) then 2247 Write_Eol; 2248 Write_Line ("Ignored units:"); 2249 2250 Indent; 2251 2252 for Unit_Num in Done'Range loop 2253 if not Done (Unit_Num) then 2254 Write_Unit_Info 2255 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); 2256 end if; 2257 end loop; 2258 2259 Outdent; 2260 end if; 2261 end if; 2262 2263 pragma Assert (Done (Main_Unit)); 2264 2265 if Debug_Unit_Walk then 2266 Outdent; 2267 Write_Line ("end Walk_Library_Items."); 2268 end if; 2269 end Walk_Library_Items; 2270 2271 ---------------- 2272 -- Walk_Withs -- 2273 ---------------- 2274 2275 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is 2276 pragma Assert (Nkind (CU) = N_Compilation_Unit); 2277 pragma Assert (Nkind (Unit (CU)) /= N_Subunit); 2278 2279 procedure Walk_Immediate is new Walk_Withs_Immediate (Action); 2280 2281 begin 2282 -- First walk the withs immediately on the library item 2283 2284 Walk_Immediate (CU, Include_Limited); 2285 2286 -- For a body, we must also check for any subunits which belong to it 2287 -- and which have context clauses of their own, since these with'ed 2288 -- units are part of its own dependencies. 2289 2290 if Nkind (Unit (CU)) in N_Unit_Body then 2291 for S in Main_Unit .. Last_Unit loop 2292 2293 -- We are only interested in subunits. For preproc. data and def. 2294 -- files, Cunit is Empty, so we need to test that first. 2295 2296 if Cunit (S) /= Empty 2297 and then Nkind (Unit (Cunit (S))) = N_Subunit 2298 then 2299 declare 2300 Pnode : Node_Id; 2301 2302 begin 2303 Pnode := Library_Unit (Cunit (S)); 2304 2305 -- In -gnatc mode, the errors in the subunits will not have 2306 -- been recorded, but the analysis of the subunit may have 2307 -- failed, so just quit. 2308 2309 if No (Pnode) then 2310 exit; 2311 end if; 2312 2313 -- Find ultimate parent of the subunit 2314 2315 while Nkind (Unit (Pnode)) = N_Subunit loop 2316 Pnode := Library_Unit (Pnode); 2317 end loop; 2318 2319 -- See if it belongs to current unit, and if so, include its 2320 -- with_clauses. Do not process main unit prematurely. 2321 2322 if Pnode = CU and then CU /= Cunit (Main_Unit) then 2323 Walk_Immediate (Cunit (S), Include_Limited); 2324 end if; 2325 end; 2326 end if; 2327 end loop; 2328 end if; 2329 end Walk_Withs; 2330 2331 -------------------------- 2332 -- Walk_Withs_Immediate -- 2333 -------------------------- 2334 2335 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is 2336 pragma Assert (Nkind (CU) = N_Compilation_Unit); 2337 2338 Context_Item : Node_Id; 2339 Lib_Unit : Node_Id; 2340 Body_CU : Node_Id; 2341 2342 begin 2343 Context_Item := First (Context_Items (CU)); 2344 while Present (Context_Item) loop 2345 if Nkind (Context_Item) = N_With_Clause 2346 and then (Include_Limited 2347 or else not Limited_Present (Context_Item)) 2348 then 2349 Lib_Unit := Library_Unit (Context_Item); 2350 Action (Lib_Unit); 2351 2352 -- If the context item indicates that a package body is needed 2353 -- because of an instantiation in CU, traverse the body now, even 2354 -- if CU is not related to the main unit. If the generic itself 2355 -- appears in a package body, the context item is this body, and 2356 -- it already appears in the traversal order, so we only need to 2357 -- examine the case of a context item being a package declaration. 2358 2359 if Present (Withed_Body (Context_Item)) 2360 and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration 2361 and then Present (Corresponding_Body (Unit (Lib_Unit))) 2362 then 2363 Body_CU := 2364 Parent 2365 (Unit_Declaration_Node 2366 (Corresponding_Body (Unit (Lib_Unit)))); 2367 2368 -- A body may have an implicit with on its own spec, in which 2369 -- case we must ignore this context item to prevent looping. 2370 2371 if Unit (CU) /= Unit (Body_CU) then 2372 Action (Body_CU); 2373 end if; 2374 end if; 2375 end if; 2376 2377 Context_Item := Next (Context_Item); 2378 end loop; 2379 end Walk_Withs_Immediate; 2380 2381end Sem; 2382