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