------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- You should have received a copy of the GNU General Public License along -- -- with this program; see file COPYING3. If not see -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Debug_A; use Debug_A; with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Fname; use Fname; with HLO; use HLO; with Lib; use Lib; with Lib.Load; use Lib.Load; with Nlists; use Nlists; with Output; use Output; with Sem_Attr; use Sem_Attr; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; with Sem_Ch10; use Sem_Ch10; with Sem_Ch11; use Sem_Ch11; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Uintp; use Uintp; with Uname; use Uname; with Unchecked_Deallocation; pragma Warnings (Off, Sem_Util); -- Suppress warnings of unused with for Sem_Util (used only in asserts) package body Sem is Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW; -- Controls debugging printouts for Walk_Library_Items Outer_Generic_Scope : Entity_Id := Empty; -- Global reference to the outer scope that is generic. In a non-generic -- context, it is empty. At the moment, it is only used for avoiding -- freezing of external references in generics. Comp_Unit_List : Elist_Id := No_Elist; -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes -- processed by Semantics, in an appropriate order. Initialized to -- No_Elist, because it's too early to call New_Elmt_List; we will set it -- to New_Elmt_List on first use. generic with procedure Action (Withed_Unit : Node_Id); procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); -- Walk all the with clauses of CU, and call Action for the with'ed unit. -- Ignore limited withs, unless Include_Limited is True. CU must be an -- N_Compilation_Unit. generic with procedure Action (Withed_Unit : Node_Id); procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean); -- Same as Walk_Withs_Immediate, but also include with clauses on subunits -- of this unit, since they count as dependences on their parent library -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit. procedure Write_Unit_Info (Unit_Num : Unit_Number_Type; Item : Node_Id; Prefix : String := ""; Withs : Boolean := False); -- Print out debugging information about the unit. Prefix precedes the rest -- of the printout. If Withs is True, we print out units with'ed by this -- unit (not counting limited withs). ------------- -- Analyze -- ------------- procedure Analyze (N : Node_Id) is begin Debug_A_Entry ("analyzing ", N); -- Immediate return if already analyzed if Analyzed (N) then Debug_A_Exit ("analyzing ", N, " (done, analyzed already)"); return; end if; -- Otherwise processing depends on the node kind case Nkind (N) is when N_Abort_Statement => Analyze_Abort_Statement (N); when N_Abstract_Subprogram_Declaration => Analyze_Abstract_Subprogram_Declaration (N); when N_Accept_Alternative => Analyze_Accept_Alternative (N); when N_Accept_Statement => Analyze_Accept_Statement (N); when N_Aggregate => Analyze_Aggregate (N); when N_Allocator => Analyze_Allocator (N); when N_And_Then => Analyze_Short_Circuit (N); when N_Assignment_Statement => Analyze_Assignment (N); when N_Asynchronous_Select => Analyze_Asynchronous_Select (N); when N_At_Clause => Analyze_At_Clause (N); when N_Attribute_Reference => Analyze_Attribute (N); when N_Attribute_Definition_Clause => Analyze_Attribute_Definition_Clause (N); when N_Block_Statement => Analyze_Block_Statement (N); when N_Case_Expression => Analyze_Case_Expression (N); when N_Case_Statement => Analyze_Case_Statement (N); when N_Character_Literal => Analyze_Character_Literal (N); when N_Code_Statement => Analyze_Code_Statement (N); when N_Compilation_Unit => Analyze_Compilation_Unit (N); when N_Component_Declaration => Analyze_Component_Declaration (N); when N_Conditional_Expression => Analyze_Conditional_Expression (N); when N_Conditional_Entry_Call => Analyze_Conditional_Entry_Call (N); when N_Delay_Alternative => Analyze_Delay_Alternative (N); when N_Delay_Relative_Statement => Analyze_Delay_Relative (N); when N_Delay_Until_Statement => Analyze_Delay_Until (N); when N_Entry_Body => Analyze_Entry_Body (N); when N_Entry_Body_Formal_Part => Analyze_Entry_Body_Formal_Part (N); when N_Entry_Call_Alternative => Analyze_Entry_Call_Alternative (N); when N_Entry_Declaration => Analyze_Entry_Declaration (N); when N_Entry_Index_Specification => Analyze_Entry_Index_Specification (N); when N_Enumeration_Representation_Clause => Analyze_Enumeration_Representation_Clause (N); when N_Exception_Declaration => Analyze_Exception_Declaration (N); when N_Exception_Renaming_Declaration => Analyze_Exception_Renaming (N); when N_Exit_Statement => Analyze_Exit_Statement (N); when N_Expanded_Name => Analyze_Expanded_Name (N); when N_Explicit_Dereference => Analyze_Explicit_Dereference (N); when N_Expression_With_Actions => Analyze_Expression_With_Actions (N); when N_Extended_Return_Statement => Analyze_Extended_Return_Statement (N); when N_Extension_Aggregate => Analyze_Aggregate (N); when N_Formal_Object_Declaration => Analyze_Formal_Object_Declaration (N); when N_Formal_Package_Declaration => Analyze_Formal_Package (N); when N_Formal_Subprogram_Declaration => Analyze_Formal_Subprogram (N); when N_Formal_Type_Declaration => Analyze_Formal_Type_Declaration (N); when N_Free_Statement => Analyze_Free_Statement (N); when N_Freeze_Entity => Analyze_Freeze_Entity (N); when N_Full_Type_Declaration => Analyze_Type_Declaration (N); when N_Function_Call => Analyze_Function_Call (N); when N_Function_Instantiation => Analyze_Function_Instantiation (N); when N_Generic_Function_Renaming_Declaration => Analyze_Generic_Function_Renaming (N); when N_Generic_Package_Declaration => Analyze_Generic_Package_Declaration (N); when N_Generic_Package_Renaming_Declaration => Analyze_Generic_Package_Renaming (N); when N_Generic_Procedure_Renaming_Declaration => Analyze_Generic_Procedure_Renaming (N); when N_Generic_Subprogram_Declaration => Analyze_Generic_Subprogram_Declaration (N); when N_Goto_Statement => Analyze_Goto_Statement (N); when N_Handled_Sequence_Of_Statements => Analyze_Handled_Statements (N); when N_Identifier => Analyze_Identifier (N); when N_If_Statement => Analyze_If_Statement (N); when N_Implicit_Label_Declaration => Analyze_Implicit_Label_Declaration (N); when N_In => Analyze_Membership_Op (N); when N_Incomplete_Type_Declaration => Analyze_Incomplete_Type_Decl (N); when N_Indexed_Component => Analyze_Indexed_Component_Form (N); when N_Integer_Literal => Analyze_Integer_Literal (N); when N_Itype_Reference => Analyze_Itype_Reference (N); when N_Label => Analyze_Label (N); when N_Loop_Statement => Analyze_Loop_Statement (N); when N_Not_In => Analyze_Membership_Op (N); when N_Null => Analyze_Null (N); when N_Null_Statement => Analyze_Null_Statement (N); when N_Number_Declaration => Analyze_Number_Declaration (N); when N_Object_Declaration => Analyze_Object_Declaration (N); when N_Object_Renaming_Declaration => Analyze_Object_Renaming (N); when N_Operator_Symbol => Analyze_Operator_Symbol (N); when N_Op_Abs => Analyze_Unary_Op (N); when N_Op_Add => Analyze_Arithmetic_Op (N); when N_Op_And => Analyze_Logical_Op (N); when N_Op_Concat => Analyze_Concatenation (N); when N_Op_Divide => Analyze_Arithmetic_Op (N); when N_Op_Eq => Analyze_Equality_Op (N); when N_Op_Expon => Analyze_Arithmetic_Op (N); when N_Op_Ge => Analyze_Comparison_Op (N); when N_Op_Gt => Analyze_Comparison_Op (N); when N_Op_Le => Analyze_Comparison_Op (N); when N_Op_Lt => Analyze_Comparison_Op (N); when N_Op_Minus => Analyze_Unary_Op (N); when N_Op_Mod => Analyze_Arithmetic_Op (N); when N_Op_Multiply => Analyze_Arithmetic_Op (N); when N_Op_Ne => Analyze_Equality_Op (N); when N_Op_Not => Analyze_Negation (N); when N_Op_Or => Analyze_Logical_Op (N); when N_Op_Plus => Analyze_Unary_Op (N); when N_Op_Rem => Analyze_Arithmetic_Op (N); when N_Op_Rotate_Left => Analyze_Arithmetic_Op (N); when N_Op_Rotate_Right => Analyze_Arithmetic_Op (N); when N_Op_Shift_Left => Analyze_Arithmetic_Op (N); when N_Op_Shift_Right => Analyze_Arithmetic_Op (N); when N_Op_Shift_Right_Arithmetic => Analyze_Arithmetic_Op (N); when N_Op_Subtract => Analyze_Arithmetic_Op (N); when N_Op_Xor => Analyze_Logical_Op (N); when N_Or_Else => Analyze_Short_Circuit (N); when N_Others_Choice => Analyze_Others_Choice (N); when N_Package_Body => Analyze_Package_Body (N); when N_Package_Body_Stub => Analyze_Package_Body_Stub (N); when N_Package_Declaration => Analyze_Package_Declaration (N); when N_Package_Instantiation => Analyze_Package_Instantiation (N); when N_Package_Renaming_Declaration => Analyze_Package_Renaming (N); when N_Package_Specification => Analyze_Package_Specification (N); when N_Parameter_Association => Analyze_Parameter_Association (N); when N_Pragma => Analyze_Pragma (N); when N_Private_Extension_Declaration => Analyze_Private_Extension_Declaration (N); when N_Private_Type_Declaration => Analyze_Private_Type_Declaration (N); when N_Procedure_Call_Statement => Analyze_Procedure_Call (N); when N_Procedure_Instantiation => Analyze_Procedure_Instantiation (N); when N_Protected_Body => Analyze_Protected_Body (N); when N_Protected_Body_Stub => Analyze_Protected_Body_Stub (N); when N_Protected_Definition => Analyze_Protected_Definition (N); when N_Protected_Type_Declaration => Analyze_Protected_Type (N); when N_Qualified_Expression => Analyze_Qualified_Expression (N); when N_Raise_Statement => Analyze_Raise_Statement (N); when N_Raise_xxx_Error => Analyze_Raise_xxx_Error (N); when N_Range => Analyze_Range (N); when N_Range_Constraint => Analyze_Range (Range_Expression (N)); when N_Real_Literal => Analyze_Real_Literal (N); when N_Record_Representation_Clause => Analyze_Record_Representation_Clause (N); when N_Reference => Analyze_Reference (N); when N_Requeue_Statement => Analyze_Requeue (N); when N_Simple_Return_Statement => Analyze_Simple_Return_Statement (N); when N_Selected_Component => Find_Selected_Component (N); -- ??? why not Analyze_Selected_Component, needs comments when N_Selective_Accept => Analyze_Selective_Accept (N); when N_Single_Protected_Declaration => Analyze_Single_Protected (N); when N_Single_Task_Declaration => Analyze_Single_Task (N); when N_Slice => Analyze_Slice (N); when N_String_Literal => Analyze_String_Literal (N); when N_Subprogram_Body => Analyze_Subprogram_Body (N); when N_Subprogram_Body_Stub => Analyze_Subprogram_Body_Stub (N); when N_Subprogram_Declaration => Analyze_Subprogram_Declaration (N); when N_Subprogram_Info => Analyze_Subprogram_Info (N); when N_Subprogram_Renaming_Declaration => Analyze_Subprogram_Renaming (N); when N_Subtype_Declaration => Analyze_Subtype_Declaration (N); when N_Subtype_Indication => Analyze_Subtype_Indication (N); when N_Subunit => Analyze_Subunit (N); when N_Task_Body => Analyze_Task_Body (N); when N_Task_Body_Stub => Analyze_Task_Body_Stub (N); when N_Task_Definition => Analyze_Task_Definition (N); when N_Task_Type_Declaration => Analyze_Task_Type (N); when N_Terminate_Alternative => Analyze_Terminate_Alternative (N); when N_Timed_Entry_Call => Analyze_Timed_Entry_Call (N); when N_Triggering_Alternative => Analyze_Triggering_Alternative (N); when N_Type_Conversion => Analyze_Type_Conversion (N); when N_Unchecked_Expression => Analyze_Unchecked_Expression (N); when N_Unchecked_Type_Conversion => Analyze_Unchecked_Type_Conversion (N); when N_Use_Package_Clause => Analyze_Use_Package (N); when N_Use_Type_Clause => Analyze_Use_Type (N); when N_Validate_Unchecked_Conversion => null; when N_Variant_Part => Analyze_Variant_Part (N); when N_With_Clause => Analyze_With_Clause (N); -- A call to analyze the Empty node is an error, but most likely it -- is an error caused by an attempt to analyze a malformed piece of -- tree caused by some other error, so if there have been any other -- errors, we just ignore it, otherwise it is a real internal error -- which we complain about. -- We must also consider the case of call to a runtime function that -- is not available in the configurable runtime. when N_Empty => pragma Assert (Serious_Errors_Detected /= 0 or else Configurable_Run_Time_Violations /= 0); null; -- A call to analyze the error node is simply ignored, to avoid -- causing cascaded errors (happens of course only in error cases) when N_Error => null; -- Push/Pop nodes normally don't come through an analyze call. An -- exception is the dummy ones bracketing a subprogram body. In any -- case there is nothing to be done to analyze such nodes. when N_Push_Pop_xxx_Label => null; -- SCIL nodes don't need analysis because they are decorated when -- they are built. They are added to the tree by Insert_Actions and -- the call to analyze them is generated when the full list is -- analyzed. when N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call | N_SCIL_Membership_Test => null; -- For the remaining node types, we generate compiler abort, because -- these nodes are always analyzed within the Sem_Chn routines and -- there should never be a case of making a call to the main Analyze -- routine for these node kinds. For example, an N_Access_Definition -- node appears only in the context of a type declaration, and is -- processed by the analyze routine for type declarations. when N_Abortable_Part | N_Access_Definition | N_Access_Function_Definition | N_Access_Procedure_Definition | N_Access_To_Object_Definition | N_Case_Expression_Alternative | N_Case_Statement_Alternative | N_Compilation_Unit_Aux | N_Component_Association | N_Component_Clause | N_Component_Definition | N_Component_List | N_Constrained_Array_Definition | N_Decimal_Fixed_Point_Definition | N_Defining_Character_Literal | N_Defining_Identifier | N_Defining_Operator_Symbol | N_Defining_Program_Unit_Name | N_Delta_Constraint | N_Derived_Type_Definition | N_Designator | N_Digits_Constraint | N_Discriminant_Association | N_Discriminant_Specification | N_Elsif_Part | N_Entry_Call_Statement | N_Enumeration_Type_Definition | N_Exception_Handler | N_Floating_Point_Definition | N_Formal_Decimal_Fixed_Point_Definition | N_Formal_Derived_Type_Definition | N_Formal_Discrete_Type_Definition | N_Formal_Floating_Point_Definition | N_Formal_Modular_Type_Definition | N_Formal_Ordinary_Fixed_Point_Definition | N_Formal_Private_Type_Definition | N_Formal_Signed_Integer_Type_Definition | N_Function_Specification | N_Generic_Association | N_Index_Or_Discriminant_Constraint | N_Iteration_Scheme | N_Loop_Parameter_Specification | N_Mod_Clause | N_Modular_Type_Definition | N_Ordinary_Fixed_Point_Definition | N_Parameter_Specification | N_Pragma_Argument_Association | N_Procedure_Specification | N_Real_Range_Specification | N_Record_Definition | N_Signed_Integer_Type_Definition | N_Unconstrained_Array_Definition | N_Unused_At_Start | N_Unused_At_End | N_Variant => raise Program_Error; end case; Debug_A_Exit ("analyzing ", N, " (done)"); -- Now that we have analyzed the node, we call the expander to perform -- possible expansion. We skip this for subexpressions, because we don't -- have the type yet, and the expander will need to know the type before -- it can do its job. For subexpression nodes, the call to the expander -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error, -- which can appear in a statement context, and needs expanding now in -- the case (distinguished by Etype, as documented in Sinfo). -- The Analyzed flag is also set at this point for non-subexpression -- nodes (in the case of subexpression nodes, we can't set the flag yet, -- since resolution and expansion have not yet been completed). Note -- that for N_Raise_xxx_Error we have to distinguish the expression -- case from the statement case. if Nkind (N) not in N_Subexpr or else (Nkind (N) in N_Raise_xxx_Error and then Etype (N) = Standard_Void_Type) then Expand (N); end if; end Analyze; -- Version with check(s) suppressed procedure Analyze (N : Node_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); Analyze (N); Scope_Suppress := Svg; end; else declare Svg : constant Boolean := Scope_Suppress (Suppress); begin Scope_Suppress (Suppress) := True; Analyze (N); Scope_Suppress (Suppress) := Svg; end; end if; end Analyze; ------------------ -- Analyze_List -- ------------------ procedure Analyze_List (L : List_Id) is Node : Node_Id; begin Node := First (L); while Present (Node) loop Analyze (Node); Next (Node); end loop; end Analyze_List; -- Version with check(s) suppressed procedure Analyze_List (L : List_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); Analyze_List (L); Scope_Suppress := Svg; end; else declare Svg : constant Boolean := Scope_Suppress (Suppress); begin Scope_Suppress (Suppress) := True; Analyze_List (L); Scope_Suppress (Suppress) := Svg; end; end if; end Analyze_List; -------------------------- -- Copy_Suppress_Status -- -------------------------- procedure Copy_Suppress_Status (C : Check_Id; From : Entity_Id; To : Entity_Id) is Found : Boolean; pragma Warnings (Off, Found); procedure Search_Stack (Top : Suppress_Stack_Entry_Ptr; Found : out Boolean); -- Search given suppress stack for matching entry for entity. If found -- then set Checks_May_Be_Suppressed on To, and push an appropriate -- entry for To onto the local suppress stack. ------------------ -- Search_Stack -- ------------------ procedure Search_Stack (Top : Suppress_Stack_Entry_Ptr; Found : out Boolean) is Ptr : Suppress_Stack_Entry_Ptr; begin Ptr := Top; while Ptr /= null loop if Ptr.Entity = From and then (Ptr.Check = All_Checks or else Ptr.Check = C) then if Ptr.Suppress then Set_Checks_May_Be_Suppressed (To, True); Push_Local_Suppress_Stack_Entry (Entity => To, Check => C, Suppress => True); Found := True; return; end if; end if; Ptr := Ptr.Prev; end loop; Found := False; return; end Search_Stack; -- Start of processing for Copy_Suppress_Status begin if not Checks_May_Be_Suppressed (From) then return; end if; -- First search the local entity suppress stack, we search this in -- reverse order so that we get the innermost entry that applies to -- this case if there are nested entries. Note that for the purpose -- of this procedure we are ONLY looking for entries corresponding -- to a two-argument Suppress, where the second argument matches From. Search_Stack (Global_Suppress_Stack_Top, Found); if Found then return; end if; -- Now search the global entity suppress table for a matching entry. -- We also search this in reverse order so that if there are multiple -- pragmas for the same entity, the last one applies. Search_Stack (Local_Suppress_Stack_Top, Found); end Copy_Suppress_Status; ------------------------- -- Enter_Generic_Scope -- ------------------------- procedure Enter_Generic_Scope (S : Entity_Id) is begin if No (Outer_Generic_Scope) then Outer_Generic_Scope := S; end if; end Enter_Generic_Scope; ------------------------ -- Exit_Generic_Scope -- ------------------------ procedure Exit_Generic_Scope (S : Entity_Id) is begin if S = Outer_Generic_Scope then Outer_Generic_Scope := Empty; end if; end Exit_Generic_Scope; ----------------------- -- Explicit_Suppress -- ----------------------- function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is Ptr : Suppress_Stack_Entry_Ptr; begin if not Checks_May_Be_Suppressed (E) then return False; else Ptr := Global_Suppress_Stack_Top; while Ptr /= null loop if Ptr.Entity = E and then (Ptr.Check = All_Checks or else Ptr.Check = C) then return Ptr.Suppress; end if; Ptr := Ptr.Prev; end loop; end if; return False; end Explicit_Suppress; ----------------------------- -- External_Ref_In_Generic -- ----------------------------- function External_Ref_In_Generic (E : Entity_Id) return Boolean is Scop : Entity_Id; begin -- Entity is global if defined outside of current outer_generic_scope: -- Either the entity has a smaller depth that the outer generic, or it -- is in a different compilation unit, or it is defined within a unit -- in the same compilation, that is not within the outer_generic. if No (Outer_Generic_Scope) then return False; elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) or else not In_Same_Source_Unit (E, Outer_Generic_Scope) then return True; else Scop := Scope (E); while Present (Scop) loop if Scop = Outer_Generic_Scope then return False; elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then return True; else Scop := Scope (Scop); end if; end loop; return True; end if; end External_Ref_In_Generic; ---------------- -- Initialize -- ---------------- procedure Initialize is Next : Suppress_Stack_Entry_Ptr; procedure Free is new Unchecked_Deallocation (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr); begin -- Free any global suppress stack entries from a previous invocation -- of the compiler (in the normal case this loop does nothing). while Suppress_Stack_Entries /= null loop Next := Global_Suppress_Stack_Top.Next; Free (Suppress_Stack_Entries); Suppress_Stack_Entries := Next; end loop; Local_Suppress_Stack_Top := null; Global_Suppress_Stack_Top := null; -- Clear scope stack, and reset global variables Scope_Stack.Init; Unloaded_Subunits := False; end Initialize; ------------------------------ -- Insert_After_And_Analyze -- ------------------------------ procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is Node : Node_Id; begin if Present (M) then -- If we are not at the end of the list, then the easiest -- coding is simply to insert before our successor if Present (Next (N)) then Insert_Before_And_Analyze (Next (N), M); -- Case of inserting at the end of the list else -- Capture the Node_Id of the node to be inserted. This Node_Id -- will still be the same after the insert operation. Node := M; Insert_After (N, M); -- Now just analyze from the inserted node to the end of -- the new list (note that this properly handles the case -- where any of the analyze calls result in the insertion of -- nodes after the analyzed node, expecting analysis). while Present (Node) loop Analyze (Node); Mark_Rewrite_Insertion (Node); Next (Node); end loop; end if; end if; end Insert_After_And_Analyze; -- Version with check(s) suppressed procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); Insert_After_And_Analyze (N, M); Scope_Suppress := Svg; end; else declare Svg : constant Boolean := Scope_Suppress (Suppress); begin Scope_Suppress (Suppress) := True; Insert_After_And_Analyze (N, M); Scope_Suppress (Suppress) := Svg; end; end if; end Insert_After_And_Analyze; ------------------------------- -- Insert_Before_And_Analyze -- ------------------------------- procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is Node : Node_Id; begin if Present (M) then -- Capture the Node_Id of the first list node to be inserted. -- This will still be the first node after the insert operation, -- since Insert_List_After does not modify the Node_Id values. Node := M; Insert_Before (N, M); -- The insertion does not change the Id's of any of the nodes in -- the list, and they are still linked, so we can simply loop from -- the original first node until we meet the node before which the -- insertion is occurring. Note that this properly handles the case -- where any of the analyzed nodes insert nodes after themselves, -- expecting them to get analyzed. while Node /= N loop Analyze (Node); Mark_Rewrite_Insertion (Node); Next (Node); end loop; end if; end Insert_Before_And_Analyze; -- Version with check(s) suppressed procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); Insert_Before_And_Analyze (N, M); Scope_Suppress := Svg; end; else declare Svg : constant Boolean := Scope_Suppress (Suppress); begin Scope_Suppress (Suppress) := True; Insert_Before_And_Analyze (N, M); Scope_Suppress (Suppress) := Svg; end; end if; end Insert_Before_And_Analyze; ----------------------------------- -- Insert_List_After_And_Analyze -- ----------------------------------- procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is After : constant Node_Id := Next (N); Node : Node_Id; begin if Is_Non_Empty_List (L) then -- Capture the Node_Id of the first list node to be inserted. -- This will still be the first node after the insert operation, -- since Insert_List_After does not modify the Node_Id values. Node := First (L); Insert_List_After (N, L); -- Now just analyze from the original first node until we get to the -- successor of the original insertion point (which may be Empty if -- the insertion point was at the end of the list). Note that this -- properly handles the case where any of the analyze calls result in -- the insertion of nodes after the analyzed node (possibly calling -- this routine recursively). while Node /= After loop Analyze (Node); Mark_Rewrite_Insertion (Node); Next (Node); end loop; end if; end Insert_List_After_And_Analyze; -- Version with check(s) suppressed procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); Insert_List_After_And_Analyze (N, L); Scope_Suppress := Svg; end; else declare Svg : constant Boolean := Scope_Suppress (Suppress); begin Scope_Suppress (Suppress) := True; Insert_List_After_And_Analyze (N, L); Scope_Suppress (Suppress) := Svg; end; end if; end Insert_List_After_And_Analyze; ------------------------------------ -- Insert_List_Before_And_Analyze -- ------------------------------------ procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is Node : Node_Id; begin if Is_Non_Empty_List (L) then -- Capture the Node_Id of the first list node to be inserted. This -- will still be the first node after the insert operation, since -- Insert_List_After does not modify the Node_Id values. Node := First (L); Insert_List_Before (N, L); -- The insertion does not change the Id's of any of the nodes in -- the list, and they are still linked, so we can simply loop from -- the original first node until we meet the node before which the -- insertion is occurring. Note that this properly handles the case -- where any of the analyzed nodes insert nodes after themselves, -- expecting them to get analyzed. while Node /= N loop Analyze (Node); Mark_Rewrite_Insertion (Node); Next (Node); end loop; end if; end Insert_List_Before_And_Analyze; -- Version with check(s) suppressed procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); Insert_List_Before_And_Analyze (N, L); Scope_Suppress := Svg; end; else declare Svg : constant Boolean := Scope_Suppress (Suppress); begin Scope_Suppress (Suppress) := True; Insert_List_Before_And_Analyze (N, L); Scope_Suppress (Suppress) := Svg; end; end if; end Insert_List_Before_And_Analyze; ------------------------- -- Is_Check_Suppressed -- ------------------------- function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is Ptr : Suppress_Stack_Entry_Ptr; begin -- First search the local entity suppress stack. We search this from the -- top of the stack down so that we get the innermost entry that applies -- to this case if there are nested entries. Ptr := Local_Suppress_Stack_Top; while Ptr /= null loop if (Ptr.Entity = Empty or else Ptr.Entity = E) and then (Ptr.Check = All_Checks or else Ptr.Check = C) then return Ptr.Suppress; end if; Ptr := Ptr.Prev; end loop; -- Now search the global entity suppress table for a matching entry. -- We also search this from the top down so that if there are multiple -- pragmas for the same entity, the last one applies (not clear what -- or whether the RM specifies this handling, but it seems reasonable). Ptr := Global_Suppress_Stack_Top; while Ptr /= null loop if (Ptr.Entity = Empty or else Ptr.Entity = E) and then (Ptr.Check = All_Checks or else Ptr.Check = C) then return Ptr.Suppress; end if; Ptr := Ptr.Prev; end loop; -- If we did not find a matching entry, then use the normal scope -- suppress value after all (actually this will be the global setting -- since it clearly was not overridden at any point). For a predefined -- check, we test the specific flag. For a user defined check, we check -- the All_Checks flag. if C in Predefined_Check_Id then return Scope_Suppress (C); else return Scope_Suppress (All_Checks); end if; end Is_Check_Suppressed; ---------- -- Lock -- ---------- procedure Lock is begin Scope_Stack.Locked := True; Scope_Stack.Release; end Lock; -------------------------------------- -- Push_Global_Suppress_Stack_Entry -- -------------------------------------- procedure Push_Global_Suppress_Stack_Entry (Entity : Entity_Id; Check : Check_Id; Suppress : Boolean) is begin Global_Suppress_Stack_Top := new Suppress_Stack_Entry' (Entity => Entity, Check => Check, Suppress => Suppress, Prev => Global_Suppress_Stack_Top, Next => Suppress_Stack_Entries); Suppress_Stack_Entries := Global_Suppress_Stack_Top; return; end Push_Global_Suppress_Stack_Entry; ------------------------------------- -- Push_Local_Suppress_Stack_Entry -- ------------------------------------- procedure Push_Local_Suppress_Stack_Entry (Entity : Entity_Id; Check : Check_Id; Suppress : Boolean) is begin Local_Suppress_Stack_Top := new Suppress_Stack_Entry' (Entity => Entity, Check => Check, Suppress => Suppress, Prev => Local_Suppress_Stack_Top, Next => Suppress_Stack_Entries); Suppress_Stack_Entries := Local_Suppress_Stack_Top; return; end Push_Local_Suppress_Stack_Entry; --------------- -- Semantics -- --------------- procedure Semantics (Comp_Unit : Node_Id) is -- The following locations save the corresponding global flags and -- variables so that they can be restored on completion. This is needed -- so that calls to Rtsfind start with the proper default values for -- these variables, and also that such calls do not disturb the settings -- for units being analyzed at a higher level. S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Full_Analysis : constant Boolean := Full_Analysis; S_GNAT_Mode : constant Boolean := GNAT_Mode; S_Global_Dis_Names : constant Boolean := Global_Discard_Names; S_In_Spec_Expr : constant Boolean := In_Spec_Expression; S_Inside_A_Generic : constant Boolean := Inside_A_Generic; S_New_Nodes_OK : constant Int := New_Nodes_OK; S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; Generic_Main : constant Boolean := Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration; -- If the main unit is generic, every compiled unit, including its -- context, is compiled with expansion disabled. Save_Config_Switches : Config_Switches_Type; -- Variable used to save values of config switches while we analyze the -- new unit, to be restored on exit for proper recursive behavior. procedure Do_Analyze; -- Procedure to analyze the compilation unit. This is called more than -- once when the high level optimizer is activated. ---------------- -- Do_Analyze -- ---------------- procedure Do_Analyze is begin Save_Scope_Stack; Push_Scope (Standard_Standard); Scope_Suppress := Suppress_Options; Scope_Stack.Table (Scope_Stack.Last).Component_Alignment_Default := Calign_Default; Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; Outer_Generic_Scope := Empty; -- Now analyze the top level compilation unit node Analyze (Comp_Unit); -- Check for scope mismatch on exit from compilation pragma Assert (Current_Scope = Standard_Standard or else Comp_Unit = Cunit (Main_Unit)); -- Then pop entry for Standard, and pop implicit types Pop_Scope; Restore_Scope_Stack; end Do_Analyze; Already_Analyzed : constant Boolean := Analyzed (Comp_Unit); -- Start of processing for Semantics begin if Debug_Unit_Walk then if Already_Analyzed then Write_Str ("(done)"); end if; Write_Unit_Info (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit), Prefix => "--> "); Indent; end if; Compiler_State := Analyzing; Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit); -- Compile predefined units with GNAT_Mode set to True, to properly -- process the categorization stuff. However, do not set GNAT_Mode -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO, -- Sequential_IO) as this would prevent pragma Extend_System from being -- taken into account, for example when Text_IO is renaming DEC.Text_IO. -- Cleaner might be to do the kludge at the point of excluding the -- pragma (do not exclude for renamings ???) if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False) then GNAT_Mode := True; end if; if Generic_Main then Expander_Mode_Save_And_Set (False); else Expander_Mode_Save_And_Set (Operating_Mode = Generate_Code or Debug_Flag_X); end if; Full_Analysis := True; Inside_A_Generic := False; In_Spec_Expression := False; Set_Comes_From_Source_Default (False); Save_Opt_Config_Switches (Save_Config_Switches); Set_Opt_Config_Switches (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)), Current_Sem_Unit = Main_Unit); -- Only do analysis of unit that has not already been analyzed if not Analyzed (Comp_Unit) then Initialize_Version (Current_Sem_Unit); if HLO_Active then Expander_Mode_Save_And_Set (False); New_Nodes_OK := 1; Do_Analyze; Reset_Analyzed_Flags (Comp_Unit); Expander_Mode_Restore; High_Level_Optimize (Comp_Unit); New_Nodes_OK := 0; end if; -- Do analysis, and then append the compilation unit onto the -- Comp_Unit_List, if appropriate. This is done after analysis, -- so if this unit depends on some others, they have already been -- appended. We ignore bodies, except for the main unit itself, and -- for subprogram bodies that act as specs. We have also to guard -- against ill-formed subunits that have an improper context. Do_Analyze; if Present (Comp_Unit) and then Nkind (Unit (Comp_Unit)) in N_Proper_Body and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body or else not Acts_As_Spec (Comp_Unit)) and then not In_Extended_Main_Source_Unit (Comp_Unit) then null; else -- Initialize if first time if No (Comp_Unit_List) then Comp_Unit_List := New_Elmt_List; end if; Append_Elmt (Comp_Unit, Comp_Unit_List); if Debug_Unit_Walk then Write_Str ("Appending "); Write_Unit_Info (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit)); end if; end if; end if; -- Save indication of dynamic elaboration checks for ALI file Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks); -- Restore settings of saved switches to entry values Current_Sem_Unit := S_Current_Sem_Unit; Full_Analysis := S_Full_Analysis; Global_Discard_Names := S_Global_Dis_Names; GNAT_Mode := S_GNAT_Mode; In_Spec_Expression := S_In_Spec_Expr; Inside_A_Generic := S_Inside_A_Generic; New_Nodes_OK := S_New_Nodes_OK; Outer_Generic_Scope := S_Outer_Gen_Scope; Restore_Opt_Config_Switches (Save_Config_Switches); Expander_Mode_Restore; if Debug_Unit_Walk then Outdent; if Already_Analyzed then Write_Str ("(done)"); end if; Write_Unit_Info (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit), Prefix => "<-- "); end if; end Semantics; ------------------------ -- Walk_Library_Items -- ------------------------ procedure Walk_Library_Items is type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; pragma Pack (Unit_Number_Set); Main_CU : constant Node_Id := Cunit (Main_Unit); Seen, Done : Unit_Number_Set := (others => False); -- Seen (X) is True after we have seen unit X in the walk. This is used -- to prevent processing the same unit more than once. Done (X) is True -- after we have fully processed X, and is used only for debugging -- printouts and assertions. Do_Main : Boolean := False; -- Flag to delay processing the main body until after all other units. -- This is needed because the spec of the main unit may appear in the -- context of some other unit. We do not want this to force processing -- of the main body before all other units have been processed. procedure Do_Action (CU : Node_Id; Item : Node_Id); -- Calls Action, with some validity checks procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id); -- Calls Do_Action, first on the units with'ed by this one, then on -- this unit. If it's an instance body, do the spec first. If it is -- an instance spec, do the body last. procedure Do_Withed_Unit (Withed_Unit : Node_Id); -- Apply Do_Unit_And_Dependents to a unit in a context clause. procedure Process_Bodies_In_Context (Comp : Node_Id); -- The main unit and its spec may depend on bodies that contain generics -- that are instantiated in them. Iterate through the corresponding -- contexts before processing main (spec/body) itself, to process bodies -- that may be present, together with their context. The spec of main -- is processed wherever it appears in the list of units, while the body -- is processed as the last unit in the list. --------------- -- Do_Action -- --------------- procedure Do_Action (CU : Node_Id; Item : Node_Id) is begin -- This calls Action at the end. All the preceding code is just -- assertions and debugging output. pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit); case Nkind (Item) is when N_Generic_Subprogram_Declaration | N_Generic_Package_Declaration | N_Package_Declaration | N_Subprogram_Declaration | N_Subprogram_Renaming_Declaration | N_Package_Renaming_Declaration | N_Generic_Function_Renaming_Declaration | N_Generic_Package_Renaming_Declaration | N_Generic_Procedure_Renaming_Declaration => -- Specs are OK null; when N_Package_Body => -- Package bodies are processed separately if the main unit -- depends on them. null; when N_Subprogram_Body => -- A subprogram body must be the main unit pragma Assert (Acts_As_Spec (CU) or else CU = Cunit (Main_Unit)); null; when N_Function_Instantiation | N_Procedure_Instantiation | N_Package_Instantiation => -- Can only happen if some generic body (needed for gnat2scil -- traversal, but not by GNAT) is not available, ignore. null; -- All other cases cannot happen when N_Subunit => pragma Assert (False, "subunit"); null; when others => pragma Assert (False); null; end case; if Present (CU) then pragma Assert (Item /= Stand.Standard_Package_Node); pragma Assert (Item = Unit (CU)); declare Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); procedure Assert_Done (Withed_Unit : Node_Id); -- Assert Withed_Unit is already Done, unless it's a body. It -- might seem strange for a with_clause to refer to a body, but -- this happens in the case of a generic instantiation, which -- gets transformed into the instance body (and the instance -- spec is also created). With clauses pointing to the -- instantiation end up pointing to the instance body. ----------------- -- Assert_Done -- ----------------- procedure Assert_Done (Withed_Unit : Node_Id) is begin if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then if not Nkind_In (Unit (Withed_Unit), N_Generic_Package_Declaration, N_Package_Body, N_Package_Renaming_Declaration, N_Subprogram_Body) then Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit))); Write_Str (" not yet walked!"); if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then Write_Str (" (self-ref)"); end if; Write_Eol; pragma Assert (False); end if; end if; end Assert_Done; procedure Assert_Withed_Units_Done is new Walk_Withs (Assert_Done); begin if Debug_Unit_Walk then Write_Unit_Info (Unit_Num, Item, Withs => True); end if; -- Main unit should come last, except in the case where we -- skipped System_Aux_Id, in which case we missed the things it -- depends on, and in the case of parent bodies if present. pragma Assert (not Done (Main_Unit) or else Present (System_Aux_Id) or else Nkind (Item) = N_Package_Body); -- We shouldn't do the same thing twice pragma Assert (not Done (Unit_Num)); -- Everything we depend upon should already be done pragma Debug (Assert_Withed_Units_Done (CU, Include_Limited => False)); end; else -- Must be Standard, which has no entry in the units table pragma Assert (Item = Stand.Standard_Package_Node); if Debug_Unit_Walk then Write_Line ("Standard"); end if; end if; Action (Item); end Do_Action; -------------------- -- Do_Withed_Unit -- -------------------- procedure Do_Withed_Unit (Withed_Unit : Node_Id) is begin Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); -- If the unit in the with_clause is a generic instance, the clause -- now denotes the instance body. Traverse the corresponding spec -- because there may be no other dependence that will force the -- traversal of its own context. if Nkind (Unit (Withed_Unit)) = N_Package_Body and then Is_Generic_Instance (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) then Do_Withed_Unit (Library_Unit (Withed_Unit)); end if; end Do_Withed_Unit; ---------------------------- -- Do_Unit_And_Dependents -- ---------------------------- procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); Child : Node_Id; Body_U : Unit_Number_Type; Parent_CU : Node_Id; procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); begin if not Seen (Unit_Num) then -- Process the with clauses Do_Withed_Units (CU, Include_Limited => False); -- Process the unit if it is a spec or the the main unit, if it -- has no previous spec or we have done all other units. if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) or else Acts_As_Spec (CU) then if CU = Cunit (Main_Unit) and then not Do_Main then Seen (Unit_Num) := False; else Seen (Unit_Num) := True; if CU = Library_Unit (Main_CU) then Process_Bodies_In_Context (CU); -- If main is a child unit, examine parent unit contexts -- to see if they include instantiated units. Also, if -- the parent itself is an instance, process its body -- because it may contain subprograms that are called -- in the main unit. if Is_Child_Unit (Cunit_Entity (Main_Unit)) then Child := Cunit_Entity (Main_Unit); while Is_Child_Unit (Child) loop Parent_CU := Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); Process_Bodies_In_Context (Parent_CU); if Nkind (Unit (Parent_CU)) = N_Package_Body and then Nkind (Original_Node (Unit (Parent_CU))) = N_Package_Instantiation and then not Seen (Get_Cunit_Unit_Number (Parent_CU)) then Body_U := Get_Cunit_Unit_Number (Parent_CU); Seen (Body_U) := True; Do_Action (Parent_CU, Unit (Parent_CU)); Done (Body_U) := True; end if; Child := Scope (Child); end loop; end if; end if; Do_Action (CU, Item); Done (Unit_Num) := True; end if; end if; end if; end Do_Unit_And_Dependents; ------------------------------- -- Process_Bodies_In_Context -- ------------------------------- procedure Process_Bodies_In_Context (Comp : Node_Id) is Body_CU : Node_Id; Body_U : Unit_Number_Type; Clause : Node_Id; Spec : Node_Id; procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); function Depends_On_Main (CU : Node_Id) return Boolean; -- The body of a unit that is withed by the spec of the main unit -- may in turn have a with_clause on that spec. In that case do not -- traverse the body, to prevent loops. It can also happen that the -- main body has a with_clause on a child, which of course has an -- implicit with on its parent. It's OK to traverse the child body -- if the main spec has been processed, otherwise we also have a -- circularity to avoid. --------------------- -- Depends_On_Main -- --------------------- function Depends_On_Main (CU : Node_Id) return Boolean is CL : Node_Id; begin CL := First (Context_Items (CU)); -- Problem does not arise with main subprograms if Nkind (Unit (Main_CU)) /= N_Package_Body then return False; end if; while Present (CL) loop if Nkind (CL) = N_With_Clause and then Library_Unit (CL) = Library_Unit (Main_CU) and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) then return True; end if; Next (CL); end loop; return False; end Depends_On_Main; -- Start of processing for Process_Bodies_In_Context begin Clause := First (Context_Items (Comp)); while Present (Clause) loop if Nkind (Clause) = N_With_Clause then Spec := Library_Unit (Clause); Body_CU := Library_Unit (Spec); -- If we are processing the spec of the main unit, load bodies -- only if the with_clause indicates that it forced the loading -- of the body for a generic instantiation. Note that bodies of -- parents that are instances have been loaded already. if Present (Body_CU) and then Body_CU /= Cunit (Main_Unit) and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body and then (Nkind (Unit (Comp)) /= N_Package_Declaration or else Present (Withed_Body (Clause))) then Body_U := Get_Cunit_Unit_Number (Body_CU); if not Seen (Body_U) and then not Depends_On_Main (Body_CU) then Seen (Body_U) := True; Do_Withed_Units (Body_CU, Include_Limited => False); Do_Action (Body_CU, Unit (Body_CU)); Done (Body_U) := True; end if; end if; end if; Next (Clause); end loop; end Process_Bodies_In_Context; -- Local Declarations Cur : Elmt_Id; -- Start of processing for Walk_Library_Items begin if Debug_Unit_Walk then Write_Line ("Walk_Library_Items:"); Indent; end if; -- Do Standard first, then walk the Comp_Unit_List Do_Action (Empty, Standard_Package_Node); -- First place the context of all instance bodies on the corresponding -- spec, because it may be needed to analyze the code at the place of -- the instantiation. Cur := First_Elmt (Comp_Unit_List); while Present (Cur) loop declare CU : constant Node_Id := Node (Cur); N : constant Node_Id := Unit (CU); begin if Nkind (N) = N_Package_Body and then Is_Generic_Instance (Defining_Entity (N)) then Append_List (Context_Items (CU), Context_Items (Library_Unit (CU))); end if; Next_Elmt (Cur); end; end loop; -- Now traverse compilation units (specs) in order Cur := First_Elmt (Comp_Unit_List); while Present (Cur) loop declare CU : constant Node_Id := Node (Cur); N : constant Node_Id := Unit (CU); begin pragma Assert (Nkind (CU) = N_Compilation_Unit); case Nkind (N) is -- If it is a subprogram body, process it if it has no -- separate spec. -- If it's a package body, ignore it, unless it is a body -- created for an instance that is the main unit. In the case -- of subprograms, the body is the wrapper package. In case of -- a package, the original file carries the body, and the spec -- appears as a later entry in the units list. -- Otherwise Bodies appear in the list only because of inlining -- or instantiations, and they are processed only if relevant -- to the main unit. The main unit itself is processed -- separately after all other specs. when N_Subprogram_Body => if Acts_As_Spec (N) then Do_Unit_And_Dependents (CU, N); end if; when N_Package_Body => if CU = Main_CU and then Nkind (Original_Node (Unit (Main_CU))) in N_Generic_Instantiation and then Present (Library_Unit (Main_CU)) then Do_Unit_And_Dependents (Library_Unit (Main_CU), Unit (Library_Unit (Main_CU))); end if; -- It's a spec, process it, and the units it depends on when others => Do_Unit_And_Dependents (CU, N); end case; end; Next_Elmt (Cur); end loop; -- Now process package bodies on which main depends, followed by bodies -- of parents, if present, and finally main itself. if not Done (Main_Unit) then Do_Main := True; declare Parent_CU : Node_Id; Body_CU : Node_Id; Body_U : Unit_Number_Type; Child : Entity_Id; begin Process_Bodies_In_Context (Main_CU); -- If the main unit is a child unit, parent bodies may be present -- because they export instances or inlined subprograms. Check for -- presence of these, which are not present in context clauses. -- Note that if the parents are instances, their bodies have been -- processed before the main spec, because they may be needed -- therein, so the following loop only affects non-instances. if Is_Child_Unit (Cunit_Entity (Main_Unit)) then Child := Cunit_Entity (Main_Unit); while Is_Child_Unit (Child) loop Parent_CU := Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); Body_CU := Library_Unit (Parent_CU); if Present (Body_CU) and then not Seen (Get_Cunit_Unit_Number (Body_CU)) then Body_U := Get_Cunit_Unit_Number (Body_CU); Seen (Body_U) := True; Do_Action (Body_CU, Unit (Body_CU)); Done (Body_U) := True; end if; Child := Scope (Child); end loop; end if; Do_Action (Main_CU, Unit (Main_CU)); Done (Main_Unit) := True; end; end if; if Debug_Unit_Walk then if Done /= (Done'Range => True) then Write_Eol; Write_Line ("Ignored units:"); Indent; for Unit_Num in Done'Range loop if not Done (Unit_Num) then Write_Unit_Info (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); end if; end loop; Outdent; end if; end if; pragma Assert (Done (Main_Unit)); if Debug_Unit_Walk then Outdent; Write_Line ("end Walk_Library_Items."); end if; end Walk_Library_Items; ---------------- -- Walk_Withs -- ---------------- procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is pragma Assert (Nkind (CU) = N_Compilation_Unit); pragma Assert (Nkind (Unit (CU)) /= N_Subunit); procedure Walk_Immediate is new Walk_Withs_Immediate (Action); begin -- First walk the withs immediately on the library item Walk_Immediate (CU, Include_Limited); -- For a body, we must also check for any subunits which belong to it -- and which have context clauses of their own, since these with'ed -- units are part of its own dependencies. if Nkind (Unit (CU)) in N_Unit_Body then for S in Main_Unit .. Last_Unit loop -- We are only interested in subunits. For preproc. data and def. -- files, Cunit is Empty, so we need to test that first. if Cunit (S) /= Empty and then Nkind (Unit (Cunit (S))) = N_Subunit then declare Pnode : Node_Id; begin Pnode := Library_Unit (Cunit (S)); -- In -gnatc mode, the errors in the subunits will not have -- been recorded, but the analysis of the subunit may have -- failed, so just quit. if No (Pnode) then exit; end if; -- Find ultimate parent of the subunit while Nkind (Unit (Pnode)) = N_Subunit loop Pnode := Library_Unit (Pnode); end loop; -- See if it belongs to current unit, and if so, include its -- with_clauses. Do not process main unit prematurely. if Pnode = CU and then CU /= Cunit (Main_Unit) then Walk_Immediate (Cunit (S), Include_Limited); end if; end; end if; end loop; end if; end Walk_Withs; -------------------------- -- Walk_Withs_Immediate -- -------------------------- procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is pragma Assert (Nkind (CU) = N_Compilation_Unit); Context_Item : Node_Id; begin Context_Item := First (Context_Items (CU)); while Present (Context_Item) loop if Nkind (Context_Item) = N_With_Clause and then (Include_Limited or else not Limited_Present (Context_Item)) then Action (Library_Unit (Context_Item)); end if; Context_Item := Next (Context_Item); end loop; end Walk_Withs_Immediate; --------------------- -- Write_Unit_Info -- --------------------- procedure Write_Unit_Info (Unit_Num : Unit_Number_Type; Item : Node_Id; Prefix : String := ""; Withs : Boolean := False) is begin Write_Str (Prefix); Write_Unit_Name (Unit_Name (Unit_Num)); Write_Str (", unit "); Write_Int (Int (Unit_Num)); Write_Str (", "); Write_Int (Int (Item)); Write_Str ("="); Write_Str (Node_Kind'Image (Nkind (Item))); if Item /= Original_Node (Item) then Write_Str (", orig = "); Write_Int (Int (Original_Node (Item))); Write_Str ("="); Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); end if; Write_Eol; -- Skip the rest if we're not supposed to print the withs if not Withs then return; end if; declare Context_Item : Node_Id; begin Context_Item := First (Context_Items (Cunit (Unit_Num))); while Present (Context_Item) and then (Nkind (Context_Item) /= N_With_Clause or else Limited_Present (Context_Item)) loop Context_Item := Next (Context_Item); end loop; if Present (Context_Item) then Indent; Write_Line ("withs:"); Indent; while Present (Context_Item) loop if Nkind (Context_Item) = N_With_Clause and then not Limited_Present (Context_Item) then pragma Assert (Present (Library_Unit (Context_Item))); Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (Context_Item)))); if Implicit_With (Context_Item) then Write_Str (" -- implicit"); end if; Write_Eol; end if; Context_Item := Next (Context_Item); end loop; Outdent; Write_Line ("end withs"); Outdent; end if; end; end Write_Unit_Info; end Sem;