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