------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2004, 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 2, 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. 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 COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- 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 Einfo; use Einfo; 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 Opt; use Opt; 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; pragma Warnings (Off, Sem_Util); -- Suppress warnings of unused with for Sem_Util (used only in asserts) package body Sem is 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. ------------- -- 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_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_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 => null; -- no semantic processing required 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_Return_Statement => Analyze_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); when N_With_Type_Clause => Analyze_With_Type_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. when N_Empty => pragma Assert (Serious_Errors_Detected /= 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; -- 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_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. This is done only for nodes that -- are not subexpressions, because in the case of subexpressions, -- 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 the Sem_Res.Resolve. -- 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) if Nkind (N) not in N_Subexpr 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 begin if not Checks_May_Be_Suppressed (From) then return; end if; -- First search the local entity suppress table, 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. for J in reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last loop declare R : Entity_Check_Suppress_Record renames Local_Entity_Suppress.Table (J); begin if R.Entity = From and then (R.Check = All_Checks or else R.Check = C) then if R.Suppress then Set_Checks_May_Be_Suppressed (To, True); Local_Entity_Suppress.Append ((Entity => To, Check => C, Suppress => True)); return; end if; end if; end; end loop; -- 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. for J in reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last loop declare R : Entity_Check_Suppress_Record renames Global_Entity_Suppress.Table (J); begin if R.Entity = From and then (R.Check = All_Checks or else R.Check = C) then if R.Suppress then Set_Checks_May_Be_Suppressed (To, True); Local_Entity_Suppress.Append ((Entity => To, Check => C, Suppress => True)); end if; end if; end; end loop; 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 begin if not Checks_May_Be_Suppressed (E) then return False; else for J in reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last loop declare R : Entity_Check_Suppress_Record renames Global_Entity_Suppress.Table (J); begin if R.Entity = E and then (R.Check = All_Checks or else R.Check = C) then return R.Suppress; end if; end; end loop; return False; end if; 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 begin Local_Entity_Suppress.Init; Global_Entity_Suppress.Init; 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 begin -- First search the local entity suppress table, we search this in -- reverse order so that we get the innermost entry that applies to -- this case if there are nested entries. for J in reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last loop declare R : Entity_Check_Suppress_Record renames Local_Entity_Suppress.Table (J); begin if (R.Entity = Empty or else R.Entity = E) and then (R.Check = All_Checks or else R.Check = C) then return R.Suppress; end if; end; end loop; -- 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 (not clear what -- or whether the RM specifies this handling, but it seems reasonable). for J in reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last loop declare R : Entity_Check_Suppress_Record renames Global_Entity_Suppress.Table (J); begin if R.Entity = E and then (R.Check = All_Checks or else R.Check = C) then return R.Suppress; end if; end; 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) return Scope_Suppress (C); end Is_Check_Suppressed; ---------- -- Lock -- ---------- procedure Lock is begin Local_Entity_Suppress.Locked := True; Global_Entity_Suppress.Locked := True; Scope_Stack.Locked := True; Local_Entity_Suppress.Release; Global_Entity_Suppress.Release; Scope_Stack.Release; end Lock; --------------- -- 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_Full_Analysis : constant Boolean := Full_Analysis; S_In_Default_Expr : constant Boolean := In_Default_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; S_Sem_Unit : constant Unit_Number_Type := 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. 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; New_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; -- Start of processing for Semantics begin Compiler_State := Analyzing; Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit); 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_Default_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))); -- 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_Analyze; 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_Sem_Unit; Full_Analysis := S_Full_Analysis; In_Default_Expression := S_In_Default_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; end Semantics; end Sem;