1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, 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_Ch2; use Sem_Ch2; 40with Sem_Ch3; use Sem_Ch3; 41with Sem_Ch4; use Sem_Ch4; 42with Sem_Ch5; use Sem_Ch5; 43with Sem_Ch6; use Sem_Ch6; 44with Sem_Ch7; use Sem_Ch7; 45with Sem_Ch8; use Sem_Ch8; 46with Sem_Ch9; use Sem_Ch9; 47with Sem_Ch10; use Sem_Ch10; 48with Sem_Ch11; use Sem_Ch11; 49with Sem_Ch12; use Sem_Ch12; 50with Sem_Ch13; use Sem_Ch13; 51with Sem_Prag; use Sem_Prag; 52with Sem_Util; use Sem_Util; 53with Sinfo; use Sinfo; 54with Stand; use Stand; 55with Stylesw; use Stylesw; 56with Uintp; use Uintp; 57with Uname; use Uname; 58 59with Unchecked_Deallocation; 60 61pragma Warnings (Off, Sem_Util); 62-- Suppress warnings of unused with for Sem_Util (used only in asserts) 63 64package body Sem is 65 66 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW; 67 -- Controls debugging printouts for Walk_Library_Items 68 69 Outer_Generic_Scope : Entity_Id := Empty; 70 -- Global reference to the outer scope that is generic. In a non-generic 71 -- context, it is empty. At the moment, it is only used for avoiding 72 -- freezing of external references in generics. 73 74 Comp_Unit_List : Elist_Id := No_Elist; 75 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes 76 -- processed by Semantics, in an appropriate order. Initialized to 77 -- No_Elist, because it's too early to call New_Elmt_List; we will set it 78 -- to New_Elmt_List on first use. 79 80 generic 81 with procedure Action (Withed_Unit : Node_Id); 82 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); 83 -- Walk all the with clauses of CU, and call Action for the with'ed unit. 84 -- Ignore limited withs, unless Include_Limited is True. CU must be an 85 -- N_Compilation_Unit. 86 87 generic 88 with procedure Action (Withed_Unit : Node_Id); 89 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean); 90 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits 91 -- of this unit, since they count as dependences on their parent library 92 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit. 93 94 ------------- 95 -- Analyze -- 96 ------------- 97 98 -- WARNING: This routine manages Ghost regions. Return statements must be 99 -- replaced by gotos which jump to the end of the routine and restore the 100 -- Ghost mode. 101 102 procedure Analyze (N : Node_Id) is 103 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 104 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 105 -- Save the Ghost-related attributes 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_Reference => 519 Analyze_Reference (N); 520 521 when N_Requeue_Statement => 522 Analyze_Requeue (N); 523 524 when N_Simple_Return_Statement => 525 Analyze_Simple_Return_Statement (N); 526 527 when N_Selected_Component => 528 Find_Selected_Component (N); 529 -- ??? why not Analyze_Selected_Component, needs comments 530 531 when N_Selective_Accept => 532 Analyze_Selective_Accept (N); 533 534 when N_Single_Protected_Declaration => 535 Analyze_Single_Protected_Declaration (N); 536 537 when N_Single_Task_Declaration => 538 Analyze_Single_Task_Declaration (N); 539 540 when N_Slice => 541 Analyze_Slice (N); 542 543 when N_String_Literal => 544 Analyze_String_Literal (N); 545 546 when N_Subprogram_Body => 547 Analyze_Subprogram_Body (N); 548 549 when N_Subprogram_Body_Stub => 550 Analyze_Subprogram_Body_Stub (N); 551 552 when N_Subprogram_Declaration => 553 Analyze_Subprogram_Declaration (N); 554 555 when N_Subprogram_Renaming_Declaration => 556 Analyze_Subprogram_Renaming (N); 557 558 when N_Subtype_Declaration => 559 Analyze_Subtype_Declaration (N); 560 561 when N_Subtype_Indication => 562 Analyze_Subtype_Indication (N); 563 564 when N_Subunit => 565 Analyze_Subunit (N); 566 567 when N_Target_Name => 568 Analyze_Target_Name (N); 569 570 when N_Task_Body => 571 Analyze_Task_Body (N); 572 573 when N_Task_Body_Stub => 574 Analyze_Task_Body_Stub (N); 575 576 when N_Task_Definition => 577 Analyze_Task_Definition (N); 578 579 when N_Task_Type_Declaration => 580 Analyze_Task_Type_Declaration (N); 581 582 when N_Terminate_Alternative => 583 Analyze_Terminate_Alternative (N); 584 585 when N_Timed_Entry_Call => 586 Analyze_Timed_Entry_Call (N); 587 588 when N_Triggering_Alternative => 589 Analyze_Triggering_Alternative (N); 590 591 when N_Type_Conversion => 592 Analyze_Type_Conversion (N); 593 594 when N_Unchecked_Expression => 595 Analyze_Unchecked_Expression (N); 596 597 when N_Unchecked_Type_Conversion => 598 Analyze_Unchecked_Type_Conversion (N); 599 600 when N_Use_Package_Clause => 601 Analyze_Use_Package (N); 602 603 when N_Use_Type_Clause => 604 Analyze_Use_Type (N); 605 606 when N_Validate_Unchecked_Conversion => 607 null; 608 609 when N_Variant_Part => 610 Analyze_Variant_Part (N); 611 612 when N_With_Clause => 613 Analyze_With_Clause (N); 614 615 -- A call to analyze a marker is ignored because the node does not 616 -- have any static and run-time semantics. 617 618 when N_Call_Marker 619 | N_Variable_Reference_Marker 620 => 621 null; 622 623 -- A call to analyze the Empty node is an error, but most likely it 624 -- is an error caused by an attempt to analyze a malformed piece of 625 -- tree caused by some other error, so if there have been any other 626 -- errors, we just ignore it, otherwise it is a real internal error 627 -- which we complain about. 628 629 -- We must also consider the case of call to a runtime function that 630 -- is not available in the configurable runtime. 631 632 when N_Empty => 633 pragma Assert (Serious_Errors_Detected /= 0 634 or else Configurable_Run_Time_Violations /= 0); 635 null; 636 637 -- A call to analyze the error node is simply ignored, to avoid 638 -- causing cascaded errors (happens of course only in error cases) 639 -- Disable expansion in case it is still enabled, to prevent other 640 -- subsequent compiler glitches. 641 642 when N_Error => 643 Expander_Mode_Save_And_Set (False); 644 null; 645 646 -- Push/Pop nodes normally don't come through an analyze call. An 647 -- exception is the dummy ones bracketing a subprogram body. In any 648 -- case there is nothing to be done to analyze such nodes. 649 650 when N_Push_Pop_xxx_Label => 651 null; 652 653 -- SCIL nodes don't need analysis because they are decorated when 654 -- they are built. They are added to the tree by Insert_Actions and 655 -- the call to analyze them is generated when the full list is 656 -- analyzed. 657 658 when N_SCIL_Dispatch_Table_Tag_Init 659 | N_SCIL_Dispatching_Call 660 | N_SCIL_Membership_Test 661 => 662 null; 663 664 -- A quantified expression with a missing "all" or "some" qualifier 665 -- looks identical to an iterated component association. By language 666 -- definition, the latter must be present within array aggregates. If 667 -- this is not the case, then the iterated component association is 668 -- really an illegal quantified expression. Diagnose this scenario. 669 670 when N_Iterated_Component_Association => 671 Diagnose_Iterated_Component_Association (N); 672 673 when N_Iterated_Element_Association => 674 null; -- May require a more precise error if misplaced. 675 676 -- For the remaining node types, we generate compiler abort, because 677 -- these nodes are always analyzed within the Sem_Chn routines and 678 -- there should never be a case of making a call to the main Analyze 679 -- routine for these node kinds. For example, an N_Access_Definition 680 -- node appears only in the context of a type declaration, and is 681 -- processed by the analyze routine for type declarations. 682 683 when N_Abortable_Part 684 | N_Access_Definition 685 | N_Access_Function_Definition 686 | N_Access_Procedure_Definition 687 | N_Access_To_Object_Definition 688 | N_Aspect_Specification 689 | N_Case_Expression_Alternative 690 | N_Case_Statement_Alternative 691 | N_Compilation_Unit_Aux 692 | N_Component_Association 693 | N_Component_Clause 694 | N_Component_Definition 695 | N_Component_List 696 | N_Constrained_Array_Definition 697 | N_Contract 698 | N_Decimal_Fixed_Point_Definition 699 | N_Defining_Character_Literal 700 | N_Defining_Identifier 701 | N_Defining_Operator_Symbol 702 | N_Defining_Program_Unit_Name 703 | N_Delta_Constraint 704 | N_Derived_Type_Definition 705 | N_Designator 706 | N_Digits_Constraint 707 | N_Discriminant_Association 708 | N_Discriminant_Specification 709 | N_Elsif_Part 710 | N_Entry_Call_Statement 711 | N_Enumeration_Type_Definition 712 | N_Exception_Handler 713 | N_Floating_Point_Definition 714 | N_Formal_Decimal_Fixed_Point_Definition 715 | N_Formal_Derived_Type_Definition 716 | N_Formal_Discrete_Type_Definition 717 | N_Formal_Floating_Point_Definition 718 | N_Formal_Modular_Type_Definition 719 | N_Formal_Ordinary_Fixed_Point_Definition 720 | N_Formal_Private_Type_Definition 721 | N_Formal_Incomplete_Type_Definition 722 | N_Formal_Signed_Integer_Type_Definition 723 | N_Function_Specification 724 | N_Generic_Association 725 | N_Index_Or_Discriminant_Constraint 726 | N_Iteration_Scheme 727 | N_Mod_Clause 728 | N_Modular_Type_Definition 729 | N_Ordinary_Fixed_Point_Definition 730 | N_Parameter_Specification 731 | N_Pragma_Argument_Association 732 | N_Procedure_Specification 733 | N_Real_Range_Specification 734 | N_Record_Definition 735 | N_Signed_Integer_Type_Definition 736 | N_Unconstrained_Array_Definition 737 | N_Unused_At_End 738 | N_Unused_At_Start 739 | N_Variant 740 => 741 raise Program_Error; 742 end case; 743 744 Debug_A_Exit ("analyzing ", N, " (done)"); 745 746 -- Mark relevant use-type and use-package clauses as effective 747 -- preferring the original node over the analyzed one in the case that 748 -- constant folding has occurred and removed references that need to be 749 -- examined. Also, if the node in question is overloaded then this is 750 -- deferred until resolution. 751 752 declare 753 Operat : Node_Id := Empty; 754 begin 755 -- Attempt to obtain a checkable operator node 756 757 if Nkind (Original_Node (N)) in N_Op then 758 Operat := Original_Node (N); 759 elsif Nkind (N) in N_Op then 760 Operat := N; 761 end if; 762 763 -- Mark the operator 764 765 if Present (Operat) 766 and then Present (Entity (Operat)) 767 and then not Is_Overloaded (Operat) 768 then 769 Mark_Use_Clauses (Operat); 770 end if; 771 end; 772 773 -- Now that we have analyzed the node, we call the expander to perform 774 -- possible expansion. We skip this for subexpressions, because we don't 775 -- have the type yet, and the expander will need to know the type before 776 -- it can do its job. For subexpression nodes, the call to the expander 777 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error, 778 -- which can appear in a statement context, and needs expanding now in 779 -- the case (distinguished by Etype, as documented in Sinfo). 780 781 -- The Analyzed flag is also set at this point for non-subexpression 782 -- nodes (in the case of subexpression nodes, we can't set the flag yet, 783 -- since resolution and expansion have not yet been completed). Note 784 -- that for N_Raise_xxx_Error we have to distinguish the expression 785 -- case from the statement case. 786 787 if Nkind (N) not in N_Subexpr 788 or else (Nkind (N) in N_Raise_xxx_Error 789 and then Etype (N) = Standard_Void_Type) 790 then 791 Expand (N); 792 793 -- Replace a reference to a renaming with the renamed object for SPARK. 794 -- In general this modification is performed by Expand_SPARK, however 795 -- certain constructs may not reach the resolution or expansion phase 796 -- and thus remain unchanged. The replacement is not performed when the 797 -- construct is overloaded as resolution must first take place. This is 798 -- also not done when analyzing a generic to preserve the original tree 799 -- and because the reference may become overloaded in the instance. 800 801 elsif GNATprove_Mode 802 and then Nkind (N) in N_Expanded_Name | N_Identifier 803 and then not Is_Overloaded (N) 804 and then not Inside_A_Generic 805 then 806 Expand_SPARK_Potential_Renaming (N); 807 end if; 808 809 Restore_Ghost_Region (Saved_GM, Saved_IGR); 810 end Analyze; 811 812 -- Version with check(s) suppressed 813 814 procedure Analyze (N : Node_Id; Suppress : Check_Id) is 815 begin 816 if Suppress = All_Checks then 817 declare 818 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 819 begin 820 Scope_Suppress.Suppress := (others => True); 821 Analyze (N); 822 Scope_Suppress.Suppress := Svs; 823 end; 824 825 else 826 declare 827 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 828 begin 829 Scope_Suppress.Suppress (Suppress) := True; 830 Analyze (N); 831 Scope_Suppress.Suppress (Suppress) := Svg; 832 end; 833 end if; 834 end Analyze; 835 836 ------------------ 837 -- Analyze_List -- 838 ------------------ 839 840 procedure Analyze_List (L : List_Id) is 841 Node : Node_Id; 842 843 begin 844 Node := First (L); 845 while Present (Node) loop 846 Analyze (Node); 847 Next (Node); 848 end loop; 849 end Analyze_List; 850 851 -- Version with check(s) suppressed 852 853 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is 854 begin 855 if Suppress = All_Checks then 856 declare 857 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 858 begin 859 Scope_Suppress.Suppress := (others => True); 860 Analyze_List (L); 861 Scope_Suppress.Suppress := Svs; 862 end; 863 864 else 865 declare 866 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 867 begin 868 Scope_Suppress.Suppress (Suppress) := True; 869 Analyze_List (L); 870 Scope_Suppress.Suppress (Suppress) := Svg; 871 end; 872 end if; 873 end Analyze_List; 874 875 -------------------------- 876 -- Copy_Suppress_Status -- 877 -------------------------- 878 879 procedure Copy_Suppress_Status 880 (C : Check_Id; 881 From : Entity_Id; 882 To : Entity_Id) 883 is 884 Found : Boolean; 885 pragma Warnings (Off, Found); 886 887 procedure Search_Stack 888 (Top : Suppress_Stack_Entry_Ptr; 889 Found : out Boolean); 890 -- Search given suppress stack for matching entry for entity. If found 891 -- then set Checks_May_Be_Suppressed on To, and push an appropriate 892 -- entry for To onto the local suppress stack. 893 894 ------------------ 895 -- Search_Stack -- 896 ------------------ 897 898 procedure Search_Stack 899 (Top : Suppress_Stack_Entry_Ptr; 900 Found : out Boolean) 901 is 902 Ptr : Suppress_Stack_Entry_Ptr; 903 904 begin 905 Ptr := Top; 906 while Ptr /= null loop 907 if Ptr.Entity = From 908 and then (Ptr.Check = All_Checks or else Ptr.Check = C) 909 then 910 if Ptr.Suppress then 911 Set_Checks_May_Be_Suppressed (To, True); 912 Push_Local_Suppress_Stack_Entry 913 (Entity => To, 914 Check => C, 915 Suppress => True); 916 Found := True; 917 return; 918 end if; 919 end if; 920 921 Ptr := Ptr.Prev; 922 end loop; 923 924 Found := False; 925 return; 926 end Search_Stack; 927 928 -- Start of processing for Copy_Suppress_Status 929 930 begin 931 if not Checks_May_Be_Suppressed (From) then 932 return; 933 end if; 934 935 -- First search the global entity suppress table for a matching entry. 936 -- We also search this in reverse order so that if there are multiple 937 -- pragmas for the same entity, the last one applies. 938 939 Search_Stack (Global_Suppress_Stack_Top, Found); 940 941 if Found then 942 return; 943 end if; 944 945 -- Now search the local entity suppress stack, we search this in 946 -- reverse order so that we get the innermost entry that applies to 947 -- this case if there are nested entries. Note that for the purpose 948 -- of this procedure we are ONLY looking for entries corresponding 949 -- to a two-argument Suppress, where the second argument matches From. 950 951 Search_Stack (Local_Suppress_Stack_Top, Found); 952 end Copy_Suppress_Status; 953 954 ------------------------- 955 -- Enter_Generic_Scope -- 956 ------------------------- 957 958 procedure Enter_Generic_Scope (S : Entity_Id) is 959 begin 960 if No (Outer_Generic_Scope) then 961 Outer_Generic_Scope := S; 962 end if; 963 end Enter_Generic_Scope; 964 965 ------------------------ 966 -- Exit_Generic_Scope -- 967 ------------------------ 968 969 procedure Exit_Generic_Scope (S : Entity_Id) is 970 begin 971 if S = Outer_Generic_Scope then 972 Outer_Generic_Scope := Empty; 973 end if; 974 end Exit_Generic_Scope; 975 976 ----------------------- 977 -- Explicit_Suppress -- 978 ----------------------- 979 980 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is 981 Ptr : Suppress_Stack_Entry_Ptr; 982 983 begin 984 if not Checks_May_Be_Suppressed (E) then 985 return False; 986 987 else 988 Ptr := Global_Suppress_Stack_Top; 989 while Ptr /= null loop 990 if Ptr.Entity = E 991 and then (Ptr.Check = All_Checks or else Ptr.Check = C) 992 then 993 return Ptr.Suppress; 994 end if; 995 996 Ptr := Ptr.Prev; 997 end loop; 998 end if; 999 1000 return False; 1001 end Explicit_Suppress; 1002 1003 ----------------------------- 1004 -- External_Ref_In_Generic -- 1005 ----------------------------- 1006 1007 function External_Ref_In_Generic (E : Entity_Id) return Boolean is 1008 Scop : Entity_Id; 1009 1010 begin 1011 -- Entity is global if defined outside of current outer_generic_scope: 1012 -- Either the entity has a smaller depth that the outer generic, or it 1013 -- is in a different compilation unit, or it is defined within a unit 1014 -- in the same compilation, that is not within the outer_generic. 1015 1016 if No (Outer_Generic_Scope) then 1017 return False; 1018 1019 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) 1020 or else not In_Same_Source_Unit (E, Outer_Generic_Scope) 1021 then 1022 return True; 1023 1024 else 1025 Scop := Scope (E); 1026 while Present (Scop) loop 1027 if Scop = Outer_Generic_Scope then 1028 return False; 1029 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then 1030 return True; 1031 else 1032 Scop := Scope (Scop); 1033 end if; 1034 end loop; 1035 1036 return True; 1037 end if; 1038 end External_Ref_In_Generic; 1039 1040 ---------------- 1041 -- Initialize -- 1042 ---------------- 1043 1044 procedure Initialize is 1045 Next : Suppress_Stack_Entry_Ptr; 1046 1047 procedure Free is new Unchecked_Deallocation 1048 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr); 1049 1050 begin 1051 -- Free any global suppress stack entries from a previous invocation 1052 -- of the compiler (in the normal case this loop does nothing). 1053 1054 while Suppress_Stack_Entries /= null loop 1055 Next := Suppress_Stack_Entries.Next; 1056 Free (Suppress_Stack_Entries); 1057 Suppress_Stack_Entries := Next; 1058 end loop; 1059 1060 Local_Suppress_Stack_Top := null; 1061 Global_Suppress_Stack_Top := null; 1062 1063 -- Clear scope stack, and reset global variables 1064 1065 Scope_Stack.Init; 1066 Unloaded_Subunits := False; 1067 end Initialize; 1068 1069 ------------------------------ 1070 -- Insert_After_And_Analyze -- 1071 ------------------------------ 1072 1073 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is 1074 Node : Node_Id; 1075 1076 begin 1077 if Present (M) then 1078 1079 -- If we are not at the end of the list, then the easiest 1080 -- coding is simply to insert before our successor. 1081 1082 if Present (Next (N)) then 1083 Insert_Before_And_Analyze (Next (N), M); 1084 1085 -- Case of inserting at the end of the list 1086 1087 else 1088 -- Capture the Node_Id of the node to be inserted. This Node_Id 1089 -- will still be the same after the insert operation. 1090 1091 Node := M; 1092 Insert_After (N, M); 1093 1094 -- Now just analyze from the inserted node to the end of 1095 -- the new list (note that this properly handles the case 1096 -- where any of the analyze calls result in the insertion of 1097 -- nodes after the analyzed node, expecting analysis). 1098 1099 while Present (Node) loop 1100 Analyze (Node); 1101 Mark_Rewrite_Insertion (Node); 1102 Next (Node); 1103 end loop; 1104 end if; 1105 end if; 1106 end Insert_After_And_Analyze; 1107 1108 -- Version with check(s) suppressed 1109 1110 procedure Insert_After_And_Analyze 1111 (N : Node_Id; 1112 M : Node_Id; 1113 Suppress : Check_Id) 1114 is 1115 begin 1116 if Suppress = All_Checks then 1117 declare 1118 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 1119 begin 1120 Scope_Suppress.Suppress := (others => True); 1121 Insert_After_And_Analyze (N, M); 1122 Scope_Suppress.Suppress := Svs; 1123 end; 1124 1125 else 1126 declare 1127 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 1128 begin 1129 Scope_Suppress.Suppress (Suppress) := True; 1130 Insert_After_And_Analyze (N, M); 1131 Scope_Suppress.Suppress (Suppress) := Svg; 1132 end; 1133 end if; 1134 end Insert_After_And_Analyze; 1135 1136 ------------------------------- 1137 -- Insert_Before_And_Analyze -- 1138 ------------------------------- 1139 1140 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is 1141 Node : Node_Id; 1142 1143 begin 1144 if Present (M) then 1145 1146 -- Capture the Node_Id of the first list node to be inserted. 1147 -- This will still be the first node after the insert operation, 1148 -- since Insert_List_After does not modify the Node_Id values. 1149 1150 Node := M; 1151 Insert_Before (N, M); 1152 1153 -- The insertion does not change the Id's of any of the nodes in 1154 -- the list, and they are still linked, so we can simply loop from 1155 -- the original first node until we meet the node before which the 1156 -- insertion is occurring. Note that this properly handles the case 1157 -- where any of the analyzed nodes insert nodes after themselves, 1158 -- expecting them to get analyzed. 1159 1160 while Node /= N loop 1161 Analyze (Node); 1162 Mark_Rewrite_Insertion (Node); 1163 Next (Node); 1164 end loop; 1165 end if; 1166 end Insert_Before_And_Analyze; 1167 1168 -- Version with check(s) suppressed 1169 1170 procedure Insert_Before_And_Analyze 1171 (N : Node_Id; 1172 M : Node_Id; 1173 Suppress : Check_Id) 1174 is 1175 begin 1176 if Suppress = All_Checks then 1177 declare 1178 Svs : constant Suppress_Array := Scope_Suppress.Suppress; 1179 begin 1180 Scope_Suppress.Suppress := (others => True); 1181 Insert_Before_And_Analyze (N, M); 1182 Scope_Suppress.Suppress := Svs; 1183 end; 1184 1185 else 1186 declare 1187 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 1188 begin 1189 Scope_Suppress.Suppress (Suppress) := True; 1190 Insert_Before_And_Analyze (N, M); 1191 Scope_Suppress.Suppress (Suppress) := Svg; 1192 end; 1193 end if; 1194 end Insert_Before_And_Analyze; 1195 1196 -------------------------------------------- 1197 -- Insert_Before_First_Source_Declaration -- 1198 -------------------------------------------- 1199 1200 procedure Insert_Before_First_Source_Declaration 1201 (Stmt : Node_Id; 1202 Decls : List_Id) 1203 is 1204 Decl : Node_Id; 1205 begin 1206 -- Inspect the declarations of the related subprogram body looking for 1207 -- the first source declaration. 1208 1209 pragma Assert (Present (Decls)); 1210 1211 Decl := First (Decls); 1212 while Present (Decl) loop 1213 if Comes_From_Source (Decl) then 1214 Insert_Before (Decl, Stmt); 1215 return; 1216 end if; 1217 1218 Next (Decl); 1219 end loop; 1220 1221 -- If we get there, then the subprogram body lacks any source 1222 -- declarations. The body of _Postconditions now acts as the 1223 -- last declaration. 1224 1225 Append (Stmt, Decls); 1226 end Insert_Before_First_Source_Declaration; 1227 1228 ----------------------------------- 1229 -- Insert_List_After_And_Analyze -- 1230 ----------------------------------- 1231 1232 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is 1233 After : constant Node_Id := Next (N); 1234 Node : Node_Id; 1235 1236 begin 1237 if Is_Non_Empty_List (L) then 1238 1239 -- Capture the Node_Id of the first list node to be inserted. 1240 -- This will still be the first node after the insert operation, 1241 -- since Insert_List_After does not modify the Node_Id values. 1242 1243 Node := First (L); 1244 Insert_List_After (N, L); 1245 1246 -- Now just analyze from the original first node until we get to the 1247 -- successor of the original insertion point (which may be Empty if 1248 -- the insertion point was at the end of the list). Note that this 1249 -- properly handles the case where any of the analyze calls result in 1250 -- the insertion of nodes after the analyzed node (possibly calling 1251 -- this routine recursively). 1252 1253 while Node /= After loop 1254 Analyze (Node); 1255 Mark_Rewrite_Insertion (Node); 1256 Next (Node); 1257 end loop; 1258 end if; 1259 end Insert_List_After_And_Analyze; 1260 1261 ------------------------------------ 1262 -- Insert_List_Before_And_Analyze -- 1263 ------------------------------------ 1264 1265 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is 1266 Node : Node_Id; 1267 1268 begin 1269 if Is_Non_Empty_List (L) then 1270 1271 -- Capture the Node_Id of the first list node to be inserted. This 1272 -- will still be the first node after the insert operation, since 1273 -- Insert_List_After does not modify the Node_Id values. 1274 1275 Node := First (L); 1276 Insert_List_Before (N, L); 1277 1278 -- The insertion does not change the Id's of any of the nodes in 1279 -- the list, and they are still linked, so we can simply loop from 1280 -- the original first node until we meet the node before which the 1281 -- insertion is occurring. Note that this properly handles the case 1282 -- where any of the analyzed nodes insert nodes after themselves, 1283 -- expecting them to get analyzed. 1284 1285 while Node /= N loop 1286 Analyze (Node); 1287 Mark_Rewrite_Insertion (Node); 1288 Next (Node); 1289 end loop; 1290 end if; 1291 end Insert_List_Before_And_Analyze; 1292 1293 ---------- 1294 -- Lock -- 1295 ---------- 1296 1297 procedure Lock is 1298 begin 1299 Scope_Stack.Release; 1300 Scope_Stack.Locked := True; 1301 end Lock; 1302 1303 ------------------------ 1304 -- Preanalysis_Active -- 1305 ------------------------ 1306 1307 function Preanalysis_Active return Boolean is 1308 begin 1309 return not Full_Analysis and not Expander_Active; 1310 end Preanalysis_Active; 1311 1312 ---------------- 1313 -- Preanalyze -- 1314 ---------------- 1315 1316 procedure Preanalyze (N : Node_Id) is 1317 Save_Full_Analysis : constant Boolean := Full_Analysis; 1318 1319 begin 1320 Full_Analysis := False; 1321 Expander_Mode_Save_And_Set (False); 1322 1323 Analyze (N); 1324 1325 Expander_Mode_Restore; 1326 Full_Analysis := Save_Full_Analysis; 1327 end Preanalyze; 1328 1329 -------------------------------------- 1330 -- Push_Global_Suppress_Stack_Entry -- 1331 -------------------------------------- 1332 1333 procedure Push_Global_Suppress_Stack_Entry 1334 (Entity : Entity_Id; 1335 Check : Check_Id; 1336 Suppress : Boolean) 1337 is 1338 begin 1339 Global_Suppress_Stack_Top := 1340 new Suppress_Stack_Entry' 1341 (Entity => Entity, 1342 Check => Check, 1343 Suppress => Suppress, 1344 Prev => Global_Suppress_Stack_Top, 1345 Next => Suppress_Stack_Entries); 1346 Suppress_Stack_Entries := Global_Suppress_Stack_Top; 1347 return; 1348 end Push_Global_Suppress_Stack_Entry; 1349 1350 ------------------------------------- 1351 -- Push_Local_Suppress_Stack_Entry -- 1352 ------------------------------------- 1353 1354 procedure Push_Local_Suppress_Stack_Entry 1355 (Entity : Entity_Id; 1356 Check : Check_Id; 1357 Suppress : Boolean) 1358 is 1359 begin 1360 Local_Suppress_Stack_Top := 1361 new Suppress_Stack_Entry' 1362 (Entity => Entity, 1363 Check => Check, 1364 Suppress => Suppress, 1365 Prev => Local_Suppress_Stack_Top, 1366 Next => Suppress_Stack_Entries); 1367 Suppress_Stack_Entries := Local_Suppress_Stack_Top; 1368 1369 return; 1370 end Push_Local_Suppress_Stack_Entry; 1371 1372 --------------- 1373 -- Semantics -- 1374 --------------- 1375 1376 procedure Semantics (Comp_Unit : Node_Id) is 1377 procedure Do_Analyze; 1378 -- Perform the analysis of the compilation unit 1379 1380 ---------------- 1381 -- Do_Analyze -- 1382 ---------------- 1383 1384 -- WARNING: This routine manages Ghost regions. Return statements must 1385 -- be replaced by gotos which jump to the end of the routine and restore 1386 -- the Ghost mode. 1387 1388 procedure Do_Analyze is 1389 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 1390 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 1391 -- Save the Ghost-related attributes to restore on exit 1392 1393 -- Generally style checks are preserved across compilations, with 1394 -- one exception: s-oscons.ads, which allows arbitrary long lines 1395 -- unconditionally, and has no restore mechanism, because it is 1396 -- intended as a lowest-level Pure package. 1397 1398 Saved_ML : constant Int := Style_Max_Line_Length; 1399 Saved_CML : constant Boolean := Style_Check_Max_Line_Length; 1400 1401 List : Elist_Id; 1402 1403 begin 1404 List := Save_Scope_Stack; 1405 Push_Scope (Standard_Standard); 1406 1407 -- Set up a clean environment before analyzing 1408 1409 Install_Ghost_Region (None, Empty); 1410 1411 Outer_Generic_Scope := Empty; 1412 Scope_Suppress := Suppress_Options; 1413 Scope_Stack.Table 1414 (Scope_Stack.Last).Component_Alignment_Default := 1415 Configuration_Component_Alignment; 1416 Scope_Stack.Table 1417 (Scope_Stack.Last).Is_Active_Stack_Base := True; 1418 1419 -- Now analyze the top level compilation unit node 1420 1421 Analyze (Comp_Unit); 1422 1423 -- Check for scope mismatch on exit from compilation 1424 1425 pragma Assert (Current_Scope = Standard_Standard 1426 or else Comp_Unit = Cunit (Main_Unit)); 1427 1428 -- Then pop entry for Standard, and pop implicit types 1429 1430 Pop_Scope; 1431 Restore_Scope_Stack (List); 1432 Restore_Ghost_Region (Saved_GM, Saved_IGR); 1433 Style_Max_Line_Length := Saved_ML; 1434 Style_Check_Max_Line_Length := Saved_CML; 1435 end Do_Analyze; 1436 1437 -- Local variables 1438 1439 -- The following locations save the corresponding global flags and 1440 -- variables so that they can be restored on completion. This is needed 1441 -- so that calls to Rtsfind start with the proper default values for 1442 -- these variables, and also that such calls do not disturb the settings 1443 -- for units being analyzed at a higher level. 1444 1445 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; 1446 S_Full_Analysis : constant Boolean := Full_Analysis; 1447 S_GNAT_Mode : constant Boolean := GNAT_Mode; 1448 S_Global_Dis_Names : constant Boolean := Global_Discard_Names; 1449 S_In_Assertion_Expr : constant Nat := In_Assertion_Expr; 1450 S_In_Declare_Expr : constant Nat := In_Declare_Expr; 1451 S_In_Default_Expr : constant Boolean := In_Default_Expr; 1452 S_In_Spec_Expr : constant Boolean := In_Spec_Expression; 1453 S_Inside_A_Generic : constant Boolean := Inside_A_Generic; 1454 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; 1455 S_Style_Check : constant Boolean := Style_Check; 1456 1457 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit); 1458 1459 Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit); 1460 -- New value of Current_Sem_Unit 1461 1462 Generic_Main : constant Boolean := 1463 Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration; 1464 -- If the main unit is generic, every compiled unit, including its 1465 -- context, is compiled with expansion disabled. 1466 1467 Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean := 1468 Curunit = Main_Unit 1469 or else 1470 (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body 1471 and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit)); 1472 -- Configuration flags have special settings when compiling a predefined 1473 -- file as a main unit. This applies to its spec as well. 1474 1475 Ext_Main_Source_Unit : constant Boolean := 1476 In_Extended_Main_Source_Unit (Comp_Unit); 1477 -- Determine if unit is in extended main source unit 1478 1479 Save_Config_Attrs : Config_Switches_Type; 1480 -- Variable used to save values of config switches while we analyze the 1481 -- new unit, to be restored on exit for proper recursive behavior. 1482 1483 Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions; 1484 -- Used to save non-partition wide restrictions before processing new 1485 -- unit. All with'ed units are analyzed with config restrictions reset 1486 -- and we need to restore these saved values at the end. 1487 1488 Save_Preanalysis_Counter : constant Nat := 1489 Inside_Preanalysis_Without_Freezing; 1490 -- Saves the preanalysis nesting-level counter; required since we may 1491 -- need to analyze a unit as a consequence of the preanalysis of an 1492 -- expression without freezing (and the loaded unit must be fully 1493 -- analyzed). 1494 1495 -- Start of processing for Semantics 1496 1497 begin 1498 Inside_Preanalysis_Without_Freezing := 0; 1499 1500 if Debug_Unit_Walk then 1501 if Already_Analyzed then 1502 Write_Str ("(done)"); 1503 end if; 1504 1505 Write_Unit_Info 1506 (Get_Cunit_Unit_Number (Comp_Unit), 1507 Unit (Comp_Unit), 1508 Prefix => "--> "); 1509 Indent; 1510 end if; 1511 1512 Compiler_State := Analyzing; 1513 Current_Sem_Unit := Curunit; 1514 1515 -- Compile predefined units with GNAT_Mode set to True, to properly 1516 -- process the categorization stuff. However, do not set GNAT_Mode 1517 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO, 1518 -- Sequential_IO) as this would prevent pragma Extend_System from being 1519 -- taken into account, for example when Text_IO is renaming DEC.Text_IO. 1520 1521 if Is_Predefined_Unit (Current_Sem_Unit) 1522 and then not Is_Predefined_Renaming (Current_Sem_Unit) 1523 then 1524 GNAT_Mode := True; 1525 end if; 1526 1527 -- For generic main, never do expansion 1528 1529 if Generic_Main then 1530 Expander_Mode_Save_And_Set (False); 1531 1532 -- Non generic case 1533 1534 else 1535 Expander_Mode_Save_And_Set 1536 1537 -- Turn on expansion if generating code 1538 1539 (Operating_Mode = Generate_Code 1540 1541 -- Or if special debug flag -gnatdx is set 1542 1543 or else Debug_Flag_X 1544 1545 -- Or if in configuration run-time mode. We do this so we get 1546 -- error messages about missing entities in the run-time even 1547 -- if we are compiling in -gnatc (no code generation) mode. 1548 -- Similar processing applies to No_Run_Time_Mode. However, 1549 -- don't do this if debug flag -gnatd.Z is set or when we are 1550 -- compiling a separate unit (this is to handle a situation 1551 -- where this new processing causes trouble). 1552 1553 or else 1554 ((Configurable_Run_Time_Mode or No_Run_Time_Mode) 1555 and then not Debug_Flag_Dot_ZZ 1556 and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit)); 1557 end if; 1558 1559 Full_Analysis := True; 1560 Inside_A_Generic := False; 1561 In_Assertion_Expr := 0; 1562 In_Declare_Expr := 0; 1563 In_Default_Expr := False; 1564 In_Spec_Expression := False; 1565 Set_Comes_From_Source_Default (False); 1566 1567 -- Save current config switches and reset then appropriately 1568 1569 Save_Config_Attrs := Save_Config_Switches; 1570 Set_Config_Switches 1571 (Is_Internal_Unit (Current_Sem_Unit), 1572 Is_Main_Unit_Or_Main_Unit_Spec); 1573 1574 -- Save current non-partition-wide restrictions 1575 1576 Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save; 1577 1578 -- For unit in main extended unit, we reset the configuration values 1579 -- for the non-partition-wide restrictions. For other units reset them. 1580 1581 if Ext_Main_Source_Unit then 1582 Restore_Config_Cunit_Boolean_Restrictions; 1583 else 1584 Reset_Cunit_Boolean_Restrictions; 1585 end if; 1586 1587 -- Turn off style checks for unit that is not in the extended main 1588 -- source unit. This improves processing efficiency for such units 1589 -- (for which we don't want style checks anyway, and where they will 1590 -- get suppressed), and is definitely needed to stop some style checks 1591 -- from invading the run-time units (e.g. overriding checks). 1592 1593 if not Ext_Main_Source_Unit then 1594 Style_Check := False; 1595 1596 -- If this is part of the extended main source unit, set style check 1597 -- mode to match the style check mode of the main source unit itself. 1598 1599 else 1600 Style_Check := Style_Check_Main; 1601 end if; 1602 1603 -- Only do analysis of unit that has not already been analyzed 1604 1605 if not Analyzed (Comp_Unit) then 1606 Initialize_Version (Current_Sem_Unit); 1607 1608 -- Do analysis, and then append the compilation unit onto the 1609 -- Comp_Unit_List, if appropriate. This is done after analysis, 1610 -- so if this unit depends on some others, they have already been 1611 -- appended. We ignore bodies, except for the main unit itself, and 1612 -- for subprogram bodies that act as specs. We have also to guard 1613 -- against ill-formed subunits that have an improper context. 1614 1615 Do_Analyze; 1616 1617 if Present (Comp_Unit) 1618 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body 1619 and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body 1620 or else not Acts_As_Spec (Comp_Unit)) 1621 and then not Ext_Main_Source_Unit 1622 then 1623 null; 1624 1625 else 1626 Append_New_Elmt (Comp_Unit, To => Comp_Unit_List); 1627 1628 if Debug_Unit_Walk then 1629 Write_Str ("Appending "); 1630 Write_Unit_Info 1631 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit)); 1632 end if; 1633 end if; 1634 end if; 1635 1636 -- Save indication of dynamic elaboration checks for ALI file 1637 1638 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks); 1639 1640 -- Restore settings of saved switches to entry values 1641 1642 Current_Sem_Unit := S_Current_Sem_Unit; 1643 Full_Analysis := S_Full_Analysis; 1644 Global_Discard_Names := S_Global_Dis_Names; 1645 GNAT_Mode := S_GNAT_Mode; 1646 In_Assertion_Expr := S_In_Assertion_Expr; 1647 In_Declare_Expr := S_In_Declare_Expr; 1648 In_Default_Expr := S_In_Default_Expr; 1649 In_Spec_Expression := S_In_Spec_Expr; 1650 Inside_A_Generic := S_Inside_A_Generic; 1651 Outer_Generic_Scope := S_Outer_Gen_Scope; 1652 Style_Check := S_Style_Check; 1653 1654 Restore_Config_Switches (Save_Config_Attrs); 1655 1656 -- Deal with restore of restrictions 1657 1658 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions); 1659 1660 Expander_Mode_Restore; 1661 1662 if Debug_Unit_Walk then 1663 Outdent; 1664 1665 if Already_Analyzed then 1666 Write_Str ("(done)"); 1667 end if; 1668 1669 Write_Unit_Info 1670 (Get_Cunit_Unit_Number (Comp_Unit), 1671 Unit (Comp_Unit), 1672 Prefix => "<-- "); 1673 end if; 1674 1675 Inside_Preanalysis_Without_Freezing := Save_Preanalysis_Counter; 1676 end Semantics; 1677 1678 -------- 1679 -- ss -- 1680 -------- 1681 1682 function ss (Index : Int) return Scope_Stack_Entry is 1683 begin 1684 return Scope_Stack.Table (Index); 1685 end ss; 1686 1687 --------- 1688 -- sst -- 1689 --------- 1690 1691 function sst return Scope_Stack_Entry is 1692 begin 1693 return ss (Scope_Stack.Last); 1694 end sst; 1695 1696 ------------ 1697 -- Unlock -- 1698 ------------ 1699 1700 procedure Unlock is 1701 begin 1702 Scope_Stack.Locked := False; 1703 end Unlock; 1704 1705 ------------------------ 1706 -- Walk_Library_Items -- 1707 ------------------------ 1708 1709 procedure Walk_Library_Items is 1710 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 1711 pragma Pack (Unit_Number_Set); 1712 1713 Main_CU : constant Node_Id := Cunit (Main_Unit); 1714 Spec_CU : Node_Id := Empty; 1715 1716 Seen, Done : Unit_Number_Set := (others => False); 1717 -- Seen (X) is True after we have seen unit X in the walk. This is used 1718 -- to prevent processing the same unit more than once. Done (X) is True 1719 -- after we have fully processed X, and is used only for debugging 1720 -- printouts and assertions. 1721 1722 Do_Main : Boolean := False; 1723 -- Flag to delay processing the main body until after all other units. 1724 -- This is needed because the spec of the main unit may appear in the 1725 -- context of some other unit. We do not want this to force processing 1726 -- of the main body before all other units have been processed. 1727 -- 1728 -- Another circularity pattern occurs when the main unit is a child unit 1729 -- and the body of an ancestor has a with-clause of the main unit or on 1730 -- one of its children. In both cases the body in question has a with- 1731 -- clause on the main unit, and must be excluded from the traversal. In 1732 -- some convoluted cases this may lead to a CodePeer error because the 1733 -- spec of a subprogram declared in an instance within the parent will 1734 -- not be seen in the main unit. 1735 1736 function Depends_On_Main (CU : Node_Id) return Boolean; 1737 -- The body of a unit that is withed by the spec of the main unit may in 1738 -- turn have a with_clause on that spec. In that case do not traverse 1739 -- the body, to prevent loops. It can also happen that the main body has 1740 -- a with_clause on a child, which of course has an implicit with on its 1741 -- parent. It's OK to traverse the child body if the main spec has been 1742 -- processed, otherwise we also have a circularity to avoid. 1743 1744 procedure Do_Action (CU : Node_Id; Item : Node_Id); 1745 -- Calls Action, with some validity checks 1746 1747 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id); 1748 -- Calls Do_Action, first on the units with'ed by this one, then on 1749 -- this unit. If it's an instance body, do the spec first. If it is 1750 -- an instance spec, do the body last. 1751 1752 procedure Do_Withed_Unit (Withed_Unit : Node_Id); 1753 -- Apply Do_Unit_And_Dependents to a unit in a context clause 1754 1755 procedure Process_Bodies_In_Context (Comp : Node_Id); 1756 -- The main unit and its spec may depend on bodies that contain generics 1757 -- that are instantiated in them. Iterate through the corresponding 1758 -- contexts before processing main (spec/body) itself, to process bodies 1759 -- that may be present, together with their context. The spec of main 1760 -- is processed wherever it appears in the list of units, while the body 1761 -- is processed as the last unit in the list. 1762 1763 --------------------- 1764 -- Depends_On_Main -- 1765 --------------------- 1766 1767 function Depends_On_Main (CU : Node_Id) return Boolean is 1768 CL : Node_Id; 1769 MCU : constant Node_Id := Unit (Main_CU); 1770 1771 begin 1772 -- Problem does not arise with main subprograms 1773 1774 if Nkind (MCU) not in N_Package_Body | N_Package_Declaration then 1775 return False; 1776 end if; 1777 1778 CL := First (Context_Items (CU)); 1779 1780 while Present (CL) loop 1781 if Nkind (CL) = N_With_Clause 1782 and then Library_Unit (CL) = Main_CU 1783 and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) 1784 then 1785 return True; 1786 end if; 1787 1788 Next (CL); 1789 end loop; 1790 1791 return False; 1792 end Depends_On_Main; 1793 1794 --------------- 1795 -- Do_Action -- 1796 --------------- 1797 1798 procedure Do_Action (CU : Node_Id; Item : Node_Id) is 1799 begin 1800 -- This calls Action at the end. All the preceding code is just 1801 -- assertions and debugging output. 1802 1803 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit); 1804 1805 case Nkind (Item) is 1806 when N_Generic_Function_Renaming_Declaration 1807 | N_Generic_Package_Declaration 1808 | N_Generic_Package_Renaming_Declaration 1809 | N_Generic_Procedure_Renaming_Declaration 1810 | N_Generic_Subprogram_Declaration 1811 | N_Package_Declaration 1812 | N_Package_Renaming_Declaration 1813 | N_Subprogram_Declaration 1814 | N_Subprogram_Renaming_Declaration 1815 => 1816 -- Specs are OK 1817 1818 null; 1819 1820 when N_Package_Body => 1821 1822 -- Package bodies are processed separately if the main unit 1823 -- depends on them. 1824 1825 null; 1826 1827 when N_Subprogram_Body => 1828 1829 -- A subprogram body must be the main unit 1830 1831 pragma Assert (Acts_As_Spec (CU) or else CU = Main_CU); 1832 null; 1833 1834 when N_Function_Instantiation 1835 | N_Package_Instantiation 1836 | N_Procedure_Instantiation 1837 => 1838 -- Can only happen if some generic body (needed for gnat2scil 1839 -- traversal, but not by GNAT) is not available, ignore. 1840 1841 null; 1842 1843 -- All other cases cannot happen 1844 1845 when N_Subunit => 1846 pragma Assert (False, "subunit"); 1847 null; 1848 1849 when N_Null_Statement => 1850 1851 -- Do not call Action for an ignored ghost unit 1852 1853 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (Item))); 1854 return; 1855 1856 when others => 1857 pragma Assert (False); 1858 null; 1859 end case; 1860 1861 if Present (CU) then 1862 pragma Assert (Item /= Stand.Standard_Package_Node); 1863 pragma Assert (Item = Unit (CU)); 1864 1865 declare 1866 Unit_Num : constant Unit_Number_Type := 1867 Get_Cunit_Unit_Number (CU); 1868 1869 procedure Assert_Done (Withed_Unit : Node_Id); 1870 -- Assert Withed_Unit is already Done, unless it's a body. It 1871 -- might seem strange for a with_clause to refer to a body, but 1872 -- this happens in the case of a generic instantiation, which 1873 -- gets transformed into the instance body (and the instance 1874 -- spec is also created). With clauses pointing to the 1875 -- instantiation end up pointing to the instance body. 1876 1877 ----------------- 1878 -- Assert_Done -- 1879 ----------------- 1880 1881 procedure Assert_Done (Withed_Unit : Node_Id) is 1882 begin 1883 if Withed_Unit /= Main_CU 1884 and then not Done (Get_Cunit_Unit_Number (Withed_Unit)) 1885 then 1886 -- N_Null_Statement will happen in case of a ghost unit 1887 -- which gets rewritten. 1888 1889 if Nkind (Unit (Withed_Unit)) not in 1890 N_Generic_Package_Declaration | 1891 N_Package_Body | 1892 N_Package_Renaming_Declaration | 1893 N_Subprogram_Body | 1894 N_Null_Statement 1895 then 1896 Write_Unit_Name 1897 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit))); 1898 Write_Str (" not yet walked!"); 1899 1900 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then 1901 Write_Str (" (self-ref)"); 1902 end if; 1903 1904 Write_Eol; 1905 1906 pragma Assert (False); 1907 end if; 1908 end if; 1909 end Assert_Done; 1910 1911 procedure Assert_Withed_Units_Done is 1912 new Walk_Withs (Assert_Done); 1913 1914 begin 1915 if Debug_Unit_Walk then 1916 Write_Unit_Info (Unit_Num, Item, Withs => True); 1917 end if; 1918 1919 -- Main unit should come last, except in the case where we 1920 -- skipped System_Aux_Id, in which case we missed the things it 1921 -- depends on, and in the case of parent bodies if present. 1922 1923 pragma Assert 1924 (not Done (Main_Unit) 1925 or else Present (System_Aux_Id) 1926 or else Nkind (Item) = N_Package_Body); 1927 1928 -- We shouldn't do the same thing twice 1929 1930 pragma Assert (not Done (Unit_Num)); 1931 1932 -- Everything we depend upon should already be done 1933 1934 pragma Debug 1935 (Assert_Withed_Units_Done (CU, Include_Limited => False)); 1936 end; 1937 1938 else 1939 -- Must be Standard, which has no entry in the units table 1940 1941 pragma Assert (Item = Stand.Standard_Package_Node); 1942 1943 if Debug_Unit_Walk then 1944 Write_Line ("Standard"); 1945 end if; 1946 end if; 1947 1948 Action (Item); 1949 end Do_Action; 1950 1951 -------------------- 1952 -- Do_Withed_Unit -- 1953 -------------------- 1954 1955 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is 1956 begin 1957 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); 1958 1959 -- If the unit in the with_clause is a generic instance, the clause 1960 -- now denotes the instance body. Traverse the corresponding spec 1961 -- because there may be no other dependence that will force the 1962 -- traversal of its own context. 1963 1964 if Nkind (Unit (Withed_Unit)) = N_Package_Body 1965 and then Is_Generic_Instance 1966 (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) 1967 then 1968 Do_Withed_Unit (Library_Unit (Withed_Unit)); 1969 end if; 1970 end Do_Withed_Unit; 1971 1972 ---------------------------- 1973 -- Do_Unit_And_Dependents -- 1974 ---------------------------- 1975 1976 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is 1977 Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); 1978 Child : Node_Id; 1979 Body_U : Unit_Number_Type; 1980 Parent_CU : Node_Id; 1981 1982 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); 1983 1984 begin 1985 if not Seen (Unit_Num) then 1986 1987 -- Process the with clauses 1988 1989 Do_Withed_Units (CU, Include_Limited => False); 1990 1991 -- Process the unit if it is a spec or the main unit, if it 1992 -- has no previous spec or we have done all other units. 1993 1994 if Nkind (Item) not in N_Package_Body | N_Subprogram_Body 1995 or else Acts_As_Spec (CU) 1996 then 1997 if CU = Main_CU and then not Do_Main then 1998 Seen (Unit_Num) := False; 1999 2000 else 2001 Seen (Unit_Num) := True; 2002 2003 if CU = Library_Unit (Main_CU) then 2004 Process_Bodies_In_Context (CU); 2005 2006 -- If main is a child unit, examine parent unit contexts 2007 -- to see if they include instantiated units. Also, if 2008 -- the parent itself is an instance, process its body 2009 -- because it may contain subprograms that are called 2010 -- in the main unit. 2011 2012 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then 2013 Child := Cunit_Entity (Main_Unit); 2014 while Is_Child_Unit (Child) loop 2015 Parent_CU := 2016 Cunit 2017 (Get_Cunit_Entity_Unit_Number (Scope (Child))); 2018 Process_Bodies_In_Context (Parent_CU); 2019 2020 if Nkind (Unit (Parent_CU)) = N_Package_Body 2021 and then 2022 Nkind (Original_Node (Unit (Parent_CU))) 2023 = N_Package_Instantiation 2024 and then 2025 not Seen (Get_Cunit_Unit_Number (Parent_CU)) 2026 then 2027 Body_U := Get_Cunit_Unit_Number (Parent_CU); 2028 Seen (Body_U) := True; 2029 Do_Action (Parent_CU, Unit (Parent_CU)); 2030 Done (Body_U) := True; 2031 end if; 2032 2033 Child := Scope (Child); 2034 end loop; 2035 end if; 2036 end if; 2037 2038 Do_Action (CU, Item); 2039 Done (Unit_Num) := True; 2040 end if; 2041 end if; 2042 end if; 2043 end Do_Unit_And_Dependents; 2044 2045 ------------------------------- 2046 -- Process_Bodies_In_Context -- 2047 ------------------------------- 2048 2049 procedure Process_Bodies_In_Context (Comp : Node_Id) is 2050 Body_CU : Node_Id; 2051 Body_U : Unit_Number_Type; 2052 Clause : Node_Id; 2053 Spec : Node_Id; 2054 2055 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); 2056 2057 -- Start of processing for Process_Bodies_In_Context 2058 2059 begin 2060 Clause := First (Context_Items (Comp)); 2061 while Present (Clause) loop 2062 if Nkind (Clause) = N_With_Clause then 2063 Spec := Library_Unit (Clause); 2064 Body_CU := Library_Unit (Spec); 2065 2066 -- If we are processing the spec of the main unit, load bodies 2067 -- only if the with_clause indicates that it forced the loading 2068 -- of the body for a generic instantiation. Note that bodies of 2069 -- parents that are instances have been loaded already. 2070 2071 if Present (Body_CU) 2072 and then Body_CU /= Main_CU 2073 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body 2074 and then Nkind (Unit (Comp)) /= N_Package_Declaration 2075 then 2076 Body_U := Get_Cunit_Unit_Number (Body_CU); 2077 2078 if not Seen (Body_U) 2079 and then not Depends_On_Main (Body_CU) 2080 then 2081 Seen (Body_U) := True; 2082 Do_Withed_Units (Body_CU, Include_Limited => False); 2083 Do_Action (Body_CU, Unit (Body_CU)); 2084 Done (Body_U) := True; 2085 end if; 2086 end if; 2087 end if; 2088 2089 Next (Clause); 2090 end loop; 2091 end Process_Bodies_In_Context; 2092 2093 -- Local Declarations 2094 2095 Cur : Elmt_Id; 2096 2097 -- Start of processing for Walk_Library_Items 2098 2099 begin 2100 if Debug_Unit_Walk then 2101 Write_Line ("Walk_Library_Items:"); 2102 Indent; 2103 end if; 2104 2105 -- Do Standard first, then walk the Comp_Unit_List 2106 2107 Do_Action (Empty, Standard_Package_Node); 2108 2109 -- First place the context of all instance bodies on the corresponding 2110 -- spec, because it may be needed to analyze the code at the place of 2111 -- the instantiation. 2112 2113 Cur := First_Elmt (Comp_Unit_List); 2114 while Present (Cur) loop 2115 declare 2116 CU : constant Node_Id := Node (Cur); 2117 N : constant Node_Id := Unit (CU); 2118 2119 begin 2120 if Nkind (N) = N_Package_Body 2121 and then Is_Generic_Instance (Defining_Entity (N)) 2122 then 2123 Append_List 2124 (Context_Items (CU), Context_Items (Library_Unit (CU))); 2125 end if; 2126 2127 Next_Elmt (Cur); 2128 end; 2129 end loop; 2130 2131 -- Now traverse compilation units (specs) in order 2132 2133 Cur := First_Elmt (Comp_Unit_List); 2134 while Present (Cur) loop 2135 declare 2136 CU : constant Node_Id := Node (Cur); 2137 N : constant Node_Id := Unit (CU); 2138 Par : Entity_Id; 2139 2140 begin 2141 pragma Assert (Nkind (CU) = N_Compilation_Unit); 2142 2143 case Nkind (N) is 2144 2145 -- If it is a subprogram body, process it if it has no 2146 -- separate spec. 2147 2148 -- If it's a package body, ignore it, unless it is a body 2149 -- created for an instance that is the main unit. In the case 2150 -- of subprograms, the body is the wrapper package. In case of 2151 -- a package, the original file carries the body, and the spec 2152 -- appears as a later entry in the units list. 2153 2154 -- Otherwise bodies appear in the list only because of inlining 2155 -- or instantiations, and they are processed only if relevant. 2156 -- The flag Withed_Body on a context clause indicates that a 2157 -- unit contains an instantiation that may be needed later, 2158 -- and therefore the body that contains the generic body (and 2159 -- its context) must be traversed immediately after the 2160 -- corresponding spec (see Do_Unit_And_Dependents). 2161 2162 -- The main unit itself is processed separately after all other 2163 -- specs, and relevant bodies are examined in Process_Main. 2164 2165 when N_Subprogram_Body => 2166 if Acts_As_Spec (N) then 2167 Do_Unit_And_Dependents (CU, N); 2168 end if; 2169 2170 when N_Package_Body => 2171 if CU = Main_CU 2172 and then Nkind (Original_Node (Unit (Main_CU))) in 2173 N_Generic_Instantiation 2174 and then Present (Library_Unit (Main_CU)) 2175 then 2176 Do_Unit_And_Dependents 2177 (Library_Unit (Main_CU), 2178 Unit (Library_Unit (Main_CU))); 2179 end if; 2180 2181 -- It is a spec, process it, and the units it depends on, 2182 -- unless it is a descendant of the main unit. This can happen 2183 -- when the body of a parent depends on some other descendant. 2184 2185 when N_Null_Statement => 2186 2187 -- Ignore an ignored ghost unit 2188 2189 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (N))); 2190 null; 2191 2192 when others => 2193 2194 -- Skip spec of main unit for now, we want to process it 2195 -- after all other specs. 2196 2197 if Nkind (Unit (CU)) = N_Package_Declaration 2198 and then Library_Unit (CU) = Main_CU 2199 and then CU /= Main_CU 2200 then 2201 Spec_CU := CU; 2202 else 2203 Par := Scope (Defining_Entity (Unit (CU))); 2204 2205 if Is_Child_Unit (Defining_Entity (Unit (CU))) then 2206 while Present (Par) 2207 and then Par /= Standard_Standard 2208 and then Par /= Cunit_Entity (Main_Unit) 2209 loop 2210 Par := Scope (Par); 2211 end loop; 2212 end if; 2213 2214 if Par /= Cunit_Entity (Main_Unit) then 2215 Do_Unit_And_Dependents (CU, N); 2216 end if; 2217 end if; 2218 end case; 2219 end; 2220 2221 Next_Elmt (Cur); 2222 end loop; 2223 2224 -- Now process main package spec if skipped 2225 2226 if Present (Spec_CU) then 2227 Do_Unit_And_Dependents (Spec_CU, Unit (Spec_CU)); 2228 end if; 2229 2230 -- Now process package bodies on which main depends, followed by bodies 2231 -- of parents, if present, and finally main itself. 2232 2233 if not Done (Main_Unit) then 2234 Do_Main := True; 2235 2236 Process_Main : declare 2237 Parent_CU : Node_Id; 2238 Body_CU : Node_Id; 2239 Body_U : Unit_Number_Type; 2240 Child : Entity_Id; 2241 2242 function Is_Subunit_Of_Main (U : Node_Id) return Boolean; 2243 -- If the main unit has subunits, their context may include 2244 -- bodies that are needed in the body of main. We must examine 2245 -- the context of the subunits, which are otherwise not made 2246 -- explicit in the main unit. 2247 2248 ------------------------ 2249 -- Is_Subunit_Of_Main -- 2250 ------------------------ 2251 2252 function Is_Subunit_Of_Main (U : Node_Id) return Boolean is 2253 Lib : Node_Id; 2254 2255 begin 2256 if Present (U) and then Nkind (Unit (U)) = N_Subunit then 2257 Lib := Library_Unit (U); 2258 return Lib = Main_CU or else Is_Subunit_Of_Main (Lib); 2259 else 2260 return False; 2261 end if; 2262 end Is_Subunit_Of_Main; 2263 2264 -- Start of processing for Process_Main 2265 2266 begin 2267 Process_Bodies_In_Context (Main_CU); 2268 2269 for Unit_Num in Done'Range loop 2270 if Is_Subunit_Of_Main (Cunit (Unit_Num)) then 2271 Process_Bodies_In_Context (Cunit (Unit_Num)); 2272 end if; 2273 end loop; 2274 2275 -- If the main unit is a child unit, parent bodies may be present 2276 -- because they export instances or inlined subprograms. Check for 2277 -- presence of these, which are not present in context clauses. 2278 -- Note that if the parents are instances, their bodies have been 2279 -- processed before the main spec, because they may be needed 2280 -- therein, so the following loop only affects non-instances. 2281 2282 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then 2283 Child := Cunit_Entity (Main_Unit); 2284 while Is_Child_Unit (Child) loop 2285 Parent_CU := 2286 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); 2287 Body_CU := Library_Unit (Parent_CU); 2288 2289 if Present (Body_CU) 2290 and then not Seen (Get_Cunit_Unit_Number (Body_CU)) 2291 and then not Depends_On_Main (Body_CU) 2292 then 2293 Body_U := Get_Cunit_Unit_Number (Body_CU); 2294 Seen (Body_U) := True; 2295 Do_Action (Body_CU, Unit (Body_CU)); 2296 Done (Body_U) := True; 2297 end if; 2298 2299 Child := Scope (Child); 2300 end loop; 2301 end if; 2302 2303 Do_Action (Main_CU, Unit (Main_CU)); 2304 Done (Main_Unit) := True; 2305 end Process_Main; 2306 end if; 2307 2308 if Debug_Unit_Walk then 2309 if Done /= (Done'Range => True) then 2310 Write_Eol; 2311 Write_Line ("Ignored units:"); 2312 2313 Indent; 2314 2315 for Unit_Num in Done'Range loop 2316 if not Done (Unit_Num) then 2317 2318 -- Units with configuration pragmas (.ads files) have empty 2319 -- compilation-unit nodes; skip printing info about them. 2320 2321 if Present (Cunit (Unit_Num)) then 2322 Write_Unit_Info 2323 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); 2324 end if; 2325 end if; 2326 end loop; 2327 2328 Outdent; 2329 end if; 2330 end if; 2331 2332 pragma Assert (Done (Main_Unit)); 2333 2334 if Debug_Unit_Walk then 2335 Outdent; 2336 Write_Line ("end Walk_Library_Items."); 2337 end if; 2338 end Walk_Library_Items; 2339 2340 ---------------- 2341 -- Walk_Withs -- 2342 ---------------- 2343 2344 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is 2345 pragma Assert (Nkind (CU) = N_Compilation_Unit); 2346 pragma Assert (Nkind (Unit (CU)) /= N_Subunit); 2347 2348 procedure Walk_Immediate is new Walk_Withs_Immediate (Action); 2349 2350 begin 2351 -- First walk the withs immediately on the library item 2352 2353 Walk_Immediate (CU, Include_Limited); 2354 2355 -- For a body, we must also check for any subunits which belong to it 2356 -- and which have context clauses of their own, since these with'ed 2357 -- units are part of its own dependencies. 2358 2359 if Nkind (Unit (CU)) in N_Unit_Body then 2360 for S in Main_Unit .. Last_Unit loop 2361 2362 -- We are only interested in subunits. For preproc. data and def. 2363 -- files, Cunit is Empty, so we need to test that first. 2364 2365 if Cunit (S) /= Empty 2366 and then Nkind (Unit (Cunit (S))) = N_Subunit 2367 then 2368 declare 2369 Pnode : Node_Id; 2370 2371 begin 2372 Pnode := Library_Unit (Cunit (S)); 2373 2374 -- In -gnatc mode, the errors in the subunits will not have 2375 -- been recorded, but the analysis of the subunit may have 2376 -- failed, so just quit. 2377 2378 if No (Pnode) then 2379 exit; 2380 end if; 2381 2382 -- Find ultimate parent of the subunit 2383 2384 while Nkind (Unit (Pnode)) = N_Subunit loop 2385 Pnode := Library_Unit (Pnode); 2386 end loop; 2387 2388 -- See if it belongs to current unit, and if so, include its 2389 -- with_clauses. Do not process main unit prematurely. 2390 2391 if Pnode = CU and then CU /= Cunit (Main_Unit) then 2392 Walk_Immediate (Cunit (S), Include_Limited); 2393 end if; 2394 end; 2395 end if; 2396 end loop; 2397 end if; 2398 end Walk_Withs; 2399 2400 -------------------------- 2401 -- Walk_Withs_Immediate -- 2402 -------------------------- 2403 2404 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is 2405 pragma Assert (Nkind (CU) = N_Compilation_Unit); 2406 2407 Context_Item : Node_Id; 2408 Lib_Unit : Node_Id; 2409 2410 begin 2411 Context_Item := First (Context_Items (CU)); 2412 while Present (Context_Item) loop 2413 if Nkind (Context_Item) = N_With_Clause 2414 and then (Include_Limited 2415 or else not Limited_Present (Context_Item)) 2416 then 2417 Lib_Unit := Library_Unit (Context_Item); 2418 Action (Lib_Unit); 2419 end if; 2420 2421 Next (Context_Item); 2422 end loop; 2423 end Walk_Withs_Immediate; 2424 2425end Sem; 2426