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