+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S E M --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- Copyright (C) 1992-2001, 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;
-
- Current_Error_Node := N;
-
- -- 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 (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_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_Record := Scope_Suppress;
-
- begin
- Scope_Suppress := (others => True);
- Analyze (N);
- Scope_Suppress := Svg;
- end;
-
- else
- declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
- begin
- Set_Scope_Suppress (Suppress, True);
- Analyze (N);
- Set_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_Record := Scope_Suppress;
-
- begin
- Scope_Suppress := (others => True);
- Analyze_List (L);
- Scope_Suppress := Svg;
- end;
-
- else
- declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
- begin
- Set_Scope_Suppress (Suppress, True);
- Analyze_List (L);
- Set_Scope_Suppress (Suppress, Svg);
- end;
- end if;
- end Analyze_List;
-
- -------------------------
- -- 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;
-
- -----------------------------
- -- External_Ref_In_Generic --
- -----------------------------
-
- function External_Ref_In_Generic (E : Entity_Id) return Boolean is
- 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.
-
- return Present (Outer_Generic_Scope)
- and then (Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
- or else not In_Same_Source_Unit (E, Outer_Generic_Scope));
- end External_Ref_In_Generic;
-
- ------------------------
- -- Get_Scope_Suppress --
- ------------------------
-
- function Get_Scope_Suppress (C : Check_Id) return Boolean is
- S : Suppress_Record renames Scope_Suppress;
-
- begin
- case C is
- when Access_Check => return S.Access_Checks;
- when Accessibility_Check => return S.Accessibility_Checks;
- when Discriminant_Check => return S.Discriminant_Checks;
- when Division_Check => return S.Division_Checks;
- when Elaboration_Check => return S.Discriminant_Checks;
- when Index_Check => return S.Elaboration_Checks;
- when Length_Check => return S.Discriminant_Checks;
- when Overflow_Check => return S.Overflow_Checks;
- when Range_Check => return S.Range_Checks;
- when Storage_Check => return S.Storage_Checks;
- when Tag_Check => return S.Tag_Checks;
- when All_Checks =>
- raise Program_Error;
- end case;
- end Get_Scope_Suppress;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- 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_Record := Scope_Suppress;
-
- begin
- Scope_Suppress := (others => True);
- Insert_After_And_Analyze (N, M);
- Scope_Suppress := Svg;
- end;
-
- else
- declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
- begin
- Set_Scope_Suppress (Suppress, True);
- Insert_After_And_Analyze (N, M);
- Set_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_Record := Scope_Suppress;
-
- begin
- Scope_Suppress := (others => True);
- Insert_Before_And_Analyze (N, M);
- Scope_Suppress := Svg;
- end;
-
- else
- declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
- begin
- Set_Scope_Suppress (Suppress, True);
- Insert_Before_And_Analyze (N, M);
- Set_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_Record := Scope_Suppress;
-
- begin
- Scope_Suppress := (others => True);
- Insert_List_After_And_Analyze (N, L);
- Scope_Suppress := Svg;
- end;
-
- else
- declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
- begin
- Set_Scope_Suppress (Suppress, True);
- Insert_List_After_And_Analyze (N, L);
- Set_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_Record := Scope_Suppress;
-
- begin
- Scope_Suppress := (others => True);
- Insert_List_Before_And_Analyze (N, L);
- Scope_Suppress := Svg;
- end;
-
- else
- declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
- begin
- Set_Scope_Suppress (Suppress, True);
- Insert_List_Before_And_Analyze (N, L);
- Set_Scope_Suppress (Suppress, Svg);
- end;
- end if;
- end Insert_List_Before_And_Analyze;
-
- ----------
- -- Lock --
- ----------
-
- procedure Lock is
- begin
- Entity_Suppress.Locked := True;
- Scope_Stack.Locked := True;
- 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;
-
- 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.
-
- 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 Sem
-
- begin
- Compiler_State := Analyzing;
- Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
-
- Expander_Mode_Save_And_Set
- (Operating_Mode = Generate_Code or Debug_Flag_X);
-
- 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;
-
- ------------------------
- -- Set_Scope_Suppress --
- ------------------------
-
- procedure Set_Scope_Suppress (C : Check_Id; B : Boolean) is
- S : Suppress_Record renames Scope_Suppress;
-
- begin
- case C is
- when Access_Check => S.Access_Checks := B;
- when Accessibility_Check => S.Accessibility_Checks := B;
- when Discriminant_Check => S.Discriminant_Checks := B;
- when Division_Check => S.Division_Checks := B;
- when Elaboration_Check => S.Discriminant_Checks := B;
- when Index_Check => S.Elaboration_Checks := B;
- when Length_Check => S.Discriminant_Checks := B;
- when Overflow_Check => S.Overflow_Checks := B;
- when Range_Check => S.Range_Checks := B;
- when Storage_Check => S.Storage_Checks := B;
- when Tag_Check => S.Tag_Checks := B;
- when All_Checks =>
- raise Program_Error;
- end case;
- end Set_Scope_Suppress;
-
-end Sem;
projects / msp430-gcc.git / blobdiff