X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem.adb;h=0f8f173a5ff078e9fed645efd33bd63c135cbb19;hb=ddc75e8bafc26ece2c4792f13fb36693a1b2f8ce;hp=58521e9c727f3b5065fd69a7b99ada620cdc9b33;hpb=e29e24831601dbcc701626073daca9054ac1edad;p=gcc.git diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 58521e9c727..0f8f173a5ff 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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 -- --- . -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -28,15 +27,15 @@ 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 Restrict; use Restrict; with Sem_Attr; use Sem_Attr; +with Sem_Aux; use Sem_Aux; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; @@ -67,9 +66,9 @@ package body Sem is -- 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. + -- 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 @@ -80,9 +79,9 @@ package body Sem is 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. + -- 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); @@ -91,20 +90,15 @@ package body Sem is -- 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 + GM : constant Ghost_Mode_Type := Ghost_Mode; + -- Save the current Ghost mode in effect in case the construct sets a + -- different mode. + begin Debug_A_Entry ("analyzing ", N); @@ -118,7 +112,6 @@ package body Sem is -- Otherwise processing depends on the node kind case Nkind (N) is - when N_Abort_Statement => Analyze_Abort_Statement (N); @@ -158,6 +151,9 @@ package body Sem is when N_Block_Statement => Analyze_Block_Statement (N); + when N_Case_Expression => + Analyze_Case_Expression (N); + when N_Case_Statement => Analyze_Case_Statement (N); @@ -173,8 +169,8 @@ package body Sem is when N_Component_Declaration => Analyze_Component_Declaration (N); - when N_Conditional_Expression => - Analyze_Conditional_Expression (N); + when N_Compound_Statement => + Analyze_Compound_Statement (N); when N_Conditional_Entry_Call => Analyze_Conditional_Entry_Call (N); @@ -221,6 +217,12 @@ package body Sem is when N_Explicit_Dereference => Analyze_Explicit_Dereference (N); + when N_Expression_Function => + Analyze_Expression_Function (N); + + when N_Expression_With_Actions => + Analyze_Expression_With_Actions (N); + when N_Extended_Return_Statement => Analyze_Extended_Return_Statement (N); @@ -231,10 +233,10 @@ package body Sem is Analyze_Formal_Object_Declaration (N); when N_Formal_Package_Declaration => - Analyze_Formal_Package (N); + Analyze_Formal_Package_Declaration (N); when N_Formal_Subprogram_Declaration => - Analyze_Formal_Subprogram (N); + Analyze_Formal_Subprogram_Declaration (N); when N_Formal_Type_Declaration => Analyze_Formal_Type_Declaration (N); @@ -243,10 +245,13 @@ package body Sem is Analyze_Free_Statement (N); when N_Freeze_Entity => - null; -- no semantic processing required + Analyze_Freeze_Entity (N); + + when N_Freeze_Generic_Entity => + Analyze_Freeze_Generic_Entity (N); when N_Full_Type_Declaration => - Analyze_Type_Declaration (N); + Analyze_Full_Type_Declaration (N); when N_Function_Call => Analyze_Function_Call (N); @@ -278,6 +283,9 @@ package body Sem is when N_Identifier => Analyze_Identifier (N); + when N_If_Expression => + Analyze_If_Expression (N); + when N_If_Statement => Analyze_If_Statement (N); @@ -296,12 +304,18 @@ package body Sem is when N_Integer_Literal => Analyze_Integer_Literal (N); + when N_Iterator_Specification => + Analyze_Iterator_Specification (N); + when N_Itype_Reference => Analyze_Itype_Reference (N); when N_Label => Analyze_Label (N); + when N_Loop_Parameter_Specification => + Analyze_Loop_Parameter_Specification (N); + when N_Loop_Statement => Analyze_Loop_Statement (N); @@ -363,7 +377,7 @@ package body Sem is Analyze_Unary_Op (N); when N_Op_Mod => - Analyze_Arithmetic_Op (N); + Analyze_Mod (N); when N_Op_Multiply => Analyze_Arithmetic_Op (N); @@ -456,11 +470,17 @@ package body Sem is Analyze_Protected_Definition (N); when N_Protected_Type_Declaration => - Analyze_Protected_Type (N); + Analyze_Protected_Type_Declaration (N); when N_Qualified_Expression => Analyze_Qualified_Expression (N); + when N_Quantified_Expression => + Analyze_Quantified_Expression (N); + + when N_Raise_Expression => + Analyze_Raise_Expression (N); + when N_Raise_Statement => Analyze_Raise_Statement (N); @@ -496,10 +516,10 @@ package body Sem is Analyze_Selective_Accept (N); when N_Single_Protected_Declaration => - Analyze_Single_Protected (N); + Analyze_Single_Protected_Declaration (N); when N_Single_Task_Declaration => - Analyze_Single_Task (N); + Analyze_Single_Task_Declaration (N); when N_Slice => Analyze_Slice (N); @@ -516,9 +536,6 @@ package body Sem is 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); @@ -541,7 +558,7 @@ package body Sem is Analyze_Task_Definition (N); when N_Task_Type_Declaration => - Analyze_Task_Type (N); + Analyze_Task_Type_Declaration (N); when N_Terminate_Alternative => Analyze_Terminate_Alternative (N); @@ -576,14 +593,14 @@ package body Sem is 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. + -- 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. + -- 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 @@ -603,6 +620,16 @@ package body Sem is 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 @@ -610,62 +637,63 @@ package body Sem is -- 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_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 => - + when N_Abortable_Part | + N_Access_Definition | + N_Access_Function_Definition | + N_Access_Procedure_Definition | + N_Access_To_Object_Definition | + N_Aspect_Specification | + 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_Contract | + 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_Incomplete_Type_Definition | + N_Formal_Signed_Integer_Type_Definition | + N_Function_Specification | + N_Generic_Association | + N_Index_Or_Discriminant_Constraint | + N_Iteration_Scheme | + 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; @@ -691,6 +719,11 @@ package body Sem is then Expand (N); end if; + + -- Restore the original Ghost mode once analysis and expansion have + -- taken place. + + Ghost_Mode := GM; end Analyze; -- Version with check(s) suppressed @@ -699,20 +732,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svs : constant Suppress_Array := Scope_Suppress.Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress.Suppress := (others => True); Analyze (N); - Scope_Suppress := Svg; + Scope_Suppress.Suppress := Svs; end; - else + elsif Suppress = Overflow_Check then declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Analyze (N); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Analyze; @@ -738,20 +771,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svs : constant Suppress_Array := Scope_Suppress.Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress.Suppress := (others => True); Analyze_List (L); - Scope_Suppress := Svg; + Scope_Suppress.Suppress := Svs; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Analyze_List (L); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Analyze_List; @@ -816,11 +849,9 @@ package body Sem is 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. + -- First 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 (Global_Suppress_Stack_Top, Found); @@ -828,9 +859,11 @@ package body Sem is 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. + -- Now 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 (Local_Suppress_Stack_Top, Found); end Copy_Suppress_Status; @@ -907,7 +940,6 @@ package body Sem is else Scop := Scope (E); - while Present (Scop) loop if Scop = Outer_Generic_Scope then return False; @@ -937,7 +969,7 @@ package body Sem is -- of the compiler (in the normal case this loop does nothing). while Suppress_Stack_Entries /= null loop - Next := Global_Suppress_Stack_Top.Next; + Next := Suppress_Stack_Entries.Next; Free (Suppress_Stack_Entries); Suppress_Stack_Entries := Next; end loop; @@ -1000,20 +1032,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svs : constant Suppress_Array := Scope_Suppress.Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress.Suppress := (others => True); Insert_After_And_Analyze (N, M); - Scope_Suppress := Svg; + Scope_Suppress.Suppress := Svs; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_After_And_Analyze (N, M); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_After_And_Analyze; @@ -1060,20 +1092,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svs : constant Suppress_Array := Scope_Suppress.Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress.Suppress := (others => True); Insert_Before_And_Analyze (N, M); - Scope_Suppress := Svg; + Scope_Suppress.Suppress := Svs; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_Before_And_Analyze (N, M); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_Before_And_Analyze; @@ -1096,12 +1128,12 @@ package body Sem is 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). + -- 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); @@ -1119,20 +1151,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svs : constant Suppress_Array := Scope_Suppress.Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress.Suppress := (others => True); Insert_List_After_And_Analyze (N, L); - Scope_Suppress := Svg; + Scope_Suppress.Suppress := Svs; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_List_After_And_Analyze (N, L); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_List_After_And_Analyze; @@ -1147,9 +1179,9 @@ package body Sem is 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. + -- 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); @@ -1177,77 +1209,24 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svs : constant Suppress_Array := Scope_Suppress.Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress.Suppress := (others => True); Insert_List_Before_And_Analyze (N, L); - Scope_Suppress := Svg; + Scope_Suppress.Suppress := Svs; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_List_Before_And_Analyze (N, L); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.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 -- ---------- @@ -1258,6 +1237,23 @@ package body Sem is Scope_Stack.Release; end Lock; + ---------------- + -- Preanalyze -- + ---------------- + + procedure Preanalyze (N : Node_Id) is + Save_Full_Analysis : constant Boolean := Full_Analysis; + + begin + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (N); + + Expander_Mode_Restore; + Full_Analysis := Save_Full_Analysis; + end Preanalyze; + -------------------------------------- -- Push_Global_Suppress_Stack_Entry -- -------------------------------------- @@ -1277,7 +1273,6 @@ package body Sem is Next => Suppress_Stack_Entries); Suppress_Stack_Entries := Global_Suppress_Stack_Top; return; - end Push_Global_Suppress_Stack_Entry; ------------------------------------- @@ -1307,50 +1302,33 @@ package body Sem is --------------- 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. + -- Perform the analysis of the compilation unit ---------------- -- Do_Analyze -- ---------------- procedure Do_Analyze is + GM : constant Ghost_Mode_Type := Ghost_Mode; + -- Save the current Ghost mode in effect in case the compilation unit + -- is withed from a unit with a different Ghost mode. + + List : Elist_Id; + begin - Save_Scope_Stack; + List := Save_Scope_Stack; Push_Scope (Standard_Standard); - Scope_Suppress := Suppress_Options; + + -- Set up a clean environment before analyzing + + Ghost_Mode := None; + Outer_Generic_Scope := Empty; + 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 @@ -1364,11 +1342,60 @@ package body Sem is -- Then pop entry for Standard, and pop implicit types Pop_Scope; - Restore_Scope_Stack; + Restore_Scope_Stack (List); + Ghost_Mode := GM; end Do_Analyze; + -- Local variables + + -- 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_Assertion_Expr : constant Nat := In_Assertion_Expr; + S_In_Default_Expr : constant Boolean := In_Default_Expr; + S_In_Spec_Expr : constant Boolean := In_Spec_Expression; + S_Inside_A_Generic : constant Boolean := Inside_A_Generic; + S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; + S_Style_Check : constant Boolean := Style_Check; + Already_Analyzed : constant Boolean := Analyzed (Comp_Unit); + Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit); + -- New value of Current_Sem_Unit + + 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. + + Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean := + Curunit = Main_Unit + or else + (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body + and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit)); + -- Configuration flags have special settings when compiling a predefined + -- file as a main unit. This applies to its spec as well. + + Ext_Main_Source_Unit : constant Boolean := + In_Extended_Main_Source_Unit (Comp_Unit); + -- Determine if unit is in extended main source unit + + 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. + + Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions; + -- Used to save non-partition wide restrictions before processing new + -- unit. All with'ed units are analyzed with config restrictions reset + -- and we need to restore these saved values at the end. + -- Start of processing for Semantics begin @@ -1385,7 +1412,7 @@ package body Sem is end if; Compiler_State := Analyzing; - Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit); + Current_Sem_Unit := Curunit; -- Compile predefined units with GNAT_Mode set to True, to properly -- process the categorization stuff. However, do not set GNAT_Mode @@ -1393,69 +1420,114 @@ package body Sem is -- 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; + -- For generic main, never do expansion + if Generic_Main then Expander_Mode_Save_And_Set (False); + + -- Non generic case + else Expander_Mode_Save_And_Set - (Operating_Mode = Generate_Code or Debug_Flag_X); + + -- Turn on expansion if generating code + + (Operating_Mode = Generate_Code + + -- Or if special debug flag -gnatdx is set + + or else Debug_Flag_X + + -- Or if we are generating C code + + or else Generate_C_Code + + -- Or if in configuration run-time mode. We do this so we get + -- error messages about missing entities in the run-time even + -- if we are compiling in -gnatc (no code generation) mode. + -- Similar processing applies to No_Run_Time_Mode. However, + -- don't do this if debug flag -gnatd.Z is set or when we are + -- compiling a separate unit (this is to handle a situation + -- where this new processing causes trouble). + + or else ((Configurable_Run_Time_Mode or No_Run_Time_Mode) + and not Debug_Flag_Dot_ZZ + and Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit)); end if; Full_Analysis := True; Inside_A_Generic := False; + In_Assertion_Expr := 0; + In_Default_Expr := False; In_Spec_Expression := False; - Set_Comes_From_Source_Default (False); + + -- Save current config switches and reset then appropriately + 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); + Is_Main_Unit_Or_Main_Unit_Spec); + + -- Save current non-partition-wide restrictions + + Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save; + + -- For unit in main extended unit, we reset the configuration values + -- for the non-partition-wide restrictions. For other units reset them. + + if Ext_Main_Source_Unit then + Restore_Config_Cunit_Boolean_Restrictions; + else + Reset_Cunit_Boolean_Restrictions; + end if; + + -- Turn off style checks for unit that is not in the extended main + -- source unit. This improves processing efficiency for such units + -- (for which we don't want style checks anyway, and where they will + -- get suppressed), and is definitely needed to stop some style checks + -- from invading the run-time units (e.g. overriding checks). + + if not Ext_Main_Source_Unit then + Style_Check := False; + + -- If this is part of the extended main source unit, set style check + -- mode to match the style check mode of the main source unit itself. + + else + Style_Check := Style_Check_Main; + end if; -- 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. We - -- have also to guard against ill-formed subunits that have an - -- improper context. + -- 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); + Append_New_Elmt (Comp_Unit, To => Comp_Unit_List); if Debug_Unit_Walk then Write_Str ("Appending "); @@ -1475,12 +1547,19 @@ package body Sem is Full_Analysis := S_Full_Analysis; Global_Discard_Names := S_Global_Dis_Names; GNAT_Mode := S_GNAT_Mode; + In_Assertion_Expr := S_In_Assertion_Expr; + In_Default_Expr := S_In_Default_Expr; 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; + Style_Check := S_Style_Check; Restore_Opt_Config_Switches (Save_Config_Switches); + + -- Deal with restore of restrictions + + Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions); + Expander_Mode_Restore; if Debug_Unit_Walk then @@ -1497,6 +1576,24 @@ package body Sem is end if; end Semantics; + -------- + -- ss -- + -------- + + function ss (Index : Int) return Scope_Stack_Entry is + begin + return Scope_Stack.Table (Index); + end ss; + + --------- + -- sst -- + --------- + + function sst return Scope_Stack_Entry is + begin + return ss (Scope_Stack.Last); + end sst; + ------------------------ -- Walk_Library_Items -- ------------------------ @@ -1504,12 +1601,37 @@ package body Sem is 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. + -- + -- Another circularity pattern occurs when the main unit is a child unit + -- and the body of an ancestor has a with-clause of the main unit or on + -- one of its children. In both cases the body in question has a with- + -- clause on the main unit, and must be excluded from the traversal. In + -- some convoluted cases this may lead to a CodePeer error because the + -- spec of a subprogram declared in an instance within the parent will + -- not be seen in the main 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. + procedure Do_Action (CU : Node_Id; Item : Node_Id); -- Calls Action, with some validity checks @@ -1518,6 +1640,50 @@ package body Sem is -- 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. + + --------------------- + -- Depends_On_Main -- + --------------------- + + function Depends_On_Main (CU : Node_Id) return Boolean is + CL : Node_Id; + MCU : constant Node_Id := Unit (Main_CU); + + begin + CL := First (Context_Items (CU)); + + -- Problem does not arise with main subprograms + + if + not Nkind_In (MCU, N_Package_Body, N_Package_Declaration) + then + return False; + end if; + + while Present (CL) loop + if Nkind (CL) = N_With_Clause + and then Library_Unit (CL) = 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; + --------------- -- Do_Action -- --------------- @@ -1546,12 +1712,12 @@ package body Sem is when N_Package_Body => - -- Package bodies are processed immediately after the - -- corresponding spec. + -- Package bodies are processed separately if the main unit + -- depends on them. null; - when N_Subprogram_Body => + when N_Subprogram_Body => -- A subprogram body must be the main unit @@ -1559,14 +1725,17 @@ package body Sem is or else CU = Cunit (Main_Unit)); null; - -- All other cases cannot happen - when N_Function_Instantiation | N_Procedure_Instantiation | N_Package_Instantiation => - pragma Assert (False, "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; @@ -1603,6 +1772,7 @@ package body Sem is (Unit (Withed_Unit), N_Generic_Package_Declaration, N_Package_Body, + N_Package_Renaming_Declaration, N_Subprogram_Body) then Write_Unit_Name @@ -1628,12 +1798,14 @@ package body Sem is Write_Unit_Info (Unit_Num, Item, Withs => True); end if; - -- Main unit should come last (except in the case where we + -- 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). + -- depends on, and in the case of parent bodies if present. pragma Assert - (not Done (Main_Unit) or else Present (System_Aux_Id)); + (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 @@ -1658,97 +1830,150 @@ package body Sem is 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); - - procedure Do_Withed_Unit (Withed_Unit : Node_Id); - -- Pass the buck to Do_Unit_And_Dependents - - -------------------- - -- Do_Withed_Unit -- - -------------------- - - procedure Do_Withed_Unit (Withed_Unit : Node_Id) is - begin - Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); - end Do_Withed_Unit; + 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); - -- Start of processing for Do_Unit_And_Dependents - begin - if Seen (Unit_Num) then - return; - end if; - - Seen (Unit_Num) := True; + if not Seen (Unit_Num) then - -- Process corresponding spec of body first + -- Process the with clauses - if Nkind_In (Item, N_Package_Body, N_Subprogram_Body) then - declare - Spec_Unit : constant Node_Id := Library_Unit (CU); - begin - if Spec_Unit = CU then -- ???Why needed? - pragma Assert (Acts_As_Spec (CU)); - null; - else - Do_Unit_And_Dependents (Spec_Unit, Unit (Spec_Unit)); - end if; - end; - end if; - - -- Process the with clauses + Do_Withed_Units (CU, Include_Limited => False); - Do_Withed_Units (CU, Include_Limited => False); + -- Process the unit if it is a spec or the main unit, if it + -- has no previous spec or we have done all other units. - -- Process the unit itself - - if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) - or else Acts_As_Spec (CU) - or else CU = Cunit (Main_Unit) - then + 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; - Do_Action (CU, Item); + 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; - Done (Unit_Num) := True; + Do_Action (CU, Item); + Done (Unit_Num) := True; + end if; + end if; end if; + end Do_Unit_And_Dependents; - -- Process corresponding body of spec last. However, if this body is - -- the main unit (because some dependent of the main unit depends on - -- the main unit's spec), we don't process it now. We also skip - -- processing of the body of a unit named by pragma Extend_System, - -- because it has cyclic dependences in some cases. + ------------------------------- + -- Process_Bodies_In_Context -- + ------------------------------- - -- A body that is not the main unit is present because of inlining - -- and/or instantiations, and it is best to process a body as early - -- as possible after the spec (as if an Elaborate_Body were present). - -- Currently all such bodies are added to the units list. It might - -- be possible to restrict the list to those bodies that are used - -- in the main unit. Possible optimization ??? + procedure Process_Bodies_In_Context (Comp : Node_Id) is + Body_CU : Node_Id; + Body_U : Unit_Number_Type; + Clause : Node_Id; + Spec : Node_Id; - if Nkind (Item) = N_Package_Declaration then - declare - Body_Unit : constant Node_Id := Library_Unit (CU); + procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); - begin - if Present (Body_Unit) - and then Body_Unit /= Cunit (Main_Unit) - and then Unit_Num /= Get_Source_Unit (System_Aux_Id) + -- 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 - Do_Unit_And_Dependents (Body_Unit, Unit (Body_Unit)); - Do_Action (Body_Unit, Unit (Body_Unit)); - Done (Get_Cunit_Unit_Number (Body_Unit)) := True; + 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; - end if; - end Do_Unit_And_Dependents; + end if; + + Next (Clause); + end loop; + end Process_Bodies_In_Context; -- Local Declarations @@ -1766,6 +1991,10 @@ package body Sem is 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 @@ -1773,58 +2002,173 @@ package body Sem is N : constant Node_Id := Unit (CU); begin - pragma Assert (Nkind (CU) = N_Compilation_Unit); + 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; - case Nkind (N) is + Next_Elmt (Cur); + end; + end loop; - -- If it's a body, then ignore it, unless it's an instance (in - -- which case we do the spec), or it's the main unit (in which - -- case we do it). Note that it could be both, in which case we - -- do the with_clauses of spec and body first, + -- Now traverse compilation units (specs) in order - when N_Package_Body | N_Subprogram_Body => - declare - Entity : Node_Id := N; + Cur := First_Elmt (Comp_Unit_List); + while Present (Cur) loop + declare + CU : constant Node_Id := Node (Cur); + N : constant Node_Id := Unit (CU); + Par : Entity_Id; - begin - if Nkind (Entity) = N_Subprogram_Body then - Entity := Specification (Entity); - end if; + begin + pragma Assert (Nkind (CU) = N_Compilation_Unit); + + case Nkind (N) is - Entity := Defining_Entity (Entity); + -- If it is a subprogram body, process it if it has no + -- separate spec. - if Is_Generic_Instance (Entity) then - declare - Spec_Unit : constant Node_Id := Library_Unit (CU); + -- 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. - begin - -- Move context of body to that of spec, so it - -- appears before the spec itself, in case it - -- contains nested instances that generate late - -- with_clauses that got attached to the body. + -- Otherwise bodies appear in the list only because of inlining + -- or instantiations, and they are processed only if relevant. + -- The flag Withed_Body on a context clause indicates that a + -- unit contains an instantiation that may be needed later, + -- and therefore the body that contains the generic body (and + -- its context) must be traversed immediately after the + -- corresponding spec (see Do_Unit_And_Dependents). - Append_List - (Context_Items (CU), Context_Items (Spec_Unit)); - Do_Unit_And_Dependents - (Spec_Unit, Unit (Spec_Unit)); - end; - end if; - end; + -- The main unit itself is processed separately after all other + -- specs, and relevant bodies are examined in Process_Main. - if CU = Cunit (Main_Unit) then + when N_Subprogram_Body => + if Acts_As_Spec (N) then Do_Unit_And_Dependents (CU, N); end if; - -- It's a spec, so just do it + 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, + -- unless it is a descendent of the main unit. This can + -- happen when the body of a parent depends on some other + -- descendent. when others => - Do_Unit_And_Dependents (CU, N); + Par := Scope (Defining_Entity (Unit (CU))); + + if Is_Child_Unit (Defining_Entity (Unit (CU))) then + while Present (Par) + and then Par /= Standard_Standard + and then Par /= Cunit_Entity (Main_Unit) + loop + Par := Scope (Par); + end loop; + end if; + + if Par /= Cunit_Entity (Main_Unit) then + Do_Unit_And_Dependents (CU, N); + end if; 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; + + Process_Main : declare + Parent_CU : Node_Id; + Body_CU : Node_Id; + Body_U : Unit_Number_Type; + Child : Entity_Id; + + function Is_Subunit_Of_Main (U : Node_Id) return Boolean; + -- If the main unit has subunits, their context may include + -- bodies that are needed in the body of main. We must examine + -- the context of the subunits, which are otherwise not made + -- explicit in the main unit. + + ------------------------ + -- Is_Subunit_Of_Main -- + ------------------------ + + function Is_Subunit_Of_Main (U : Node_Id) return Boolean is + Lib : Node_Id; + begin + if No (U) then + return False; + else + Lib := Library_Unit (U); + return Nkind (Unit (U)) = N_Subunit + and then + (Lib = Cunit (Main_Unit) + or else Is_Subunit_Of_Main (Lib)); + end if; + end Is_Subunit_Of_Main; + + -- Start of processing for Process_Main + + begin + Process_Bodies_In_Context (Main_CU); + + for Unit_Num in Done'Range loop + if Is_Subunit_Of_Main (Cunit (Unit_Num)) then + Process_Bodies_In_Context (Cunit (Unit_Num)); + end if; + end loop; + + -- 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)) + and then not Depends_On_Main (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 Process_Main; + end if; + if Debug_Unit_Walk then if Done /= (Done'Range => True) then Write_Eol; @@ -1900,9 +2244,9 @@ package body Sem is end loop; -- See if it belongs to current unit, and if so, include its - -- with_clauses. + -- with_clauses. Do not process main unit prematurely. - if Pnode = CU then + if Pnode = CU and then CU /= Cunit (Main_Unit) then Walk_Immediate (Cunit (S), Include_Limited); end if; end; @@ -1919,6 +2263,8 @@ package body Sem is pragma Assert (Nkind (CU) = N_Compilation_Unit); Context_Item : Node_Id; + Lib_Unit : Node_Id; + Body_CU : Node_Id; begin Context_Item := First (Context_Items (CU)); @@ -1927,89 +2273,36 @@ package body Sem is and then (Include_Limited or else not Limited_Present (Context_Item)) then - Action (Library_Unit (Context_Item)); + Lib_Unit := Library_Unit (Context_Item); + Action (Lib_Unit); + + -- If the context item indicates that a package body is needed + -- because of an instantiation in CU, traverse the body now, even + -- if CU is not related to the main unit. If the generic itself + -- appears in a package body, the context item is this body, and + -- it already appears in the traversal order, so we only need to + -- examine the case of a context item being a package declaration. + + if Present (Withed_Body (Context_Item)) + and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration + and then Present (Corresponding_Body (Unit (Lib_Unit))) + then + Body_CU := + Parent + (Unit_Declaration_Node + (Corresponding_Body (Unit (Lib_Unit)))); + + -- A body may have an implicit with on its own spec, in which + -- case we must ignore this context item to prevent looping. + + if Unit (CU) /= Unit (Body_CU) then + Action (Body_CU); + end if; + end if; 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;