diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/sem.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/sem.adb | 1326 |
1 files changed, 1326 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/sem.adb b/gcc-4.2.1/gcc/ada/sem.adb new file mode 100644 index 000000000..8c73ae952 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/sem.adb @@ -0,0 +1,1326 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005, 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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 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 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; + S_GNAT_Mode : constant Boolean := GNAT_Mode; + 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); + + -- Compile predefined units with GNAT_Mode set to True, to properly + -- process the categorization stuff. However, do not set set GNAT_Mode + -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO, + -- Sequential_IO) as this would prevent pragma System_Extend to be + -- 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 ???) + + GNAT_Mode := + GNAT_Mode + or else Is_Predefined_File_Name + (Unit_File_Name (Current_Sem_Unit), + Renamings_Included => False); + + 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)), + 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_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; + GNAT_Mode := S_GNAT_Mode; + + Restore_Opt_Config_Switches (Save_Config_Switches); + Expander_Mode_Restore; + + end Semantics; +end Sem; |