-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- You should have received a copy of the GNU General Public License along --
--- with this program; see file COPYING3. If not see --
--- <http://www.gnu.org/licenses/>. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Debug; use Debug;
with Debug_A; use Debug_A;
with Elists; use Elists;
-with Errout; use Errout;
with Expander; use Expander;
with Fname; use Fname;
-with HLO; use HLO;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Nlists; use Nlists;
with Output; use Output;
+with Restrict; use Restrict;
with Sem_Attr; use Sem_Attr;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch2; use Sem_Ch2;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
-- of this unit, since they count as dependences on their parent library
-- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
- procedure Write_Unit_Info
- (Unit_Num : Unit_Number_Type;
- Item : Node_Id;
- Prefix : String := "";
- Withs : Boolean := False);
- -- Print out debugging information about the unit. Prefix precedes the rest
- -- of the printout. If Withs is True, we print out units with'ed by this
- -- unit (not counting limited withs).
-
-------------
-- Analyze --
-------------
procedure Analyze (N : Node_Id) is
+ GM : constant Ghost_Mode_Type := Ghost_Mode;
+ -- Save the current Ghost mode in effect in case the construct sets a
+ -- different mode.
+
begin
Debug_A_Entry ("analyzing ", N);
-- Otherwise processing depends on the node kind
case Nkind (N) is
-
when N_Abort_Statement =>
Analyze_Abort_Statement (N);
when N_Component_Declaration =>
Analyze_Component_Declaration (N);
- when N_Conditional_Expression =>
- Analyze_Conditional_Expression (N);
+ when N_Compound_Statement =>
+ Analyze_Compound_Statement (N);
when N_Conditional_Entry_Call =>
Analyze_Conditional_Entry_Call (N);
when N_Explicit_Dereference =>
Analyze_Explicit_Dereference (N);
+ when N_Expression_Function =>
+ Analyze_Expression_Function (N);
+
when N_Expression_With_Actions =>
Analyze_Expression_With_Actions (N);
Analyze_Formal_Object_Declaration (N);
when N_Formal_Package_Declaration =>
- Analyze_Formal_Package (N);
+ Analyze_Formal_Package_Declaration (N);
when N_Formal_Subprogram_Declaration =>
- Analyze_Formal_Subprogram (N);
+ Analyze_Formal_Subprogram_Declaration (N);
when N_Formal_Type_Declaration =>
Analyze_Formal_Type_Declaration (N);
when N_Freeze_Entity =>
Analyze_Freeze_Entity (N);
+ when N_Freeze_Generic_Entity =>
+ Analyze_Freeze_Generic_Entity (N);
+
when N_Full_Type_Declaration =>
- Analyze_Type_Declaration (N);
+ Analyze_Full_Type_Declaration (N);
when N_Function_Call =>
Analyze_Function_Call (N);
when N_Identifier =>
Analyze_Identifier (N);
+ when N_If_Expression =>
+ Analyze_If_Expression (N);
+
when N_If_Statement =>
Analyze_If_Statement (N);
when N_Integer_Literal =>
Analyze_Integer_Literal (N);
+ when N_Iterator_Specification =>
+ Analyze_Iterator_Specification (N);
+
when N_Itype_Reference =>
Analyze_Itype_Reference (N);
when N_Label =>
Analyze_Label (N);
+ when N_Loop_Parameter_Specification =>
+ Analyze_Loop_Parameter_Specification (N);
+
when N_Loop_Statement =>
Analyze_Loop_Statement (N);
Analyze_Unary_Op (N);
when N_Op_Mod =>
- Analyze_Arithmetic_Op (N);
+ Analyze_Mod (N);
when N_Op_Multiply =>
Analyze_Arithmetic_Op (N);
Analyze_Protected_Definition (N);
when N_Protected_Type_Declaration =>
- Analyze_Protected_Type (N);
+ Analyze_Protected_Type_Declaration (N);
when N_Qualified_Expression =>
Analyze_Qualified_Expression (N);
+ when N_Quantified_Expression =>
+ Analyze_Quantified_Expression (N);
+
+ when N_Raise_Expression =>
+ Analyze_Raise_Expression (N);
+
when N_Raise_Statement =>
Analyze_Raise_Statement (N);
Analyze_Selective_Accept (N);
when N_Single_Protected_Declaration =>
- Analyze_Single_Protected (N);
+ Analyze_Single_Protected_Declaration (N);
when N_Single_Task_Declaration =>
- Analyze_Single_Task (N);
+ Analyze_Single_Task_Declaration (N);
when N_Slice =>
Analyze_Slice (N);
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);
Analyze_Task_Definition (N);
when N_Task_Type_Declaration =>
- Analyze_Task_Type (N);
+ Analyze_Task_Type_Declaration (N);
when N_Terminate_Alternative =>
Analyze_Terminate_Alternative (N);
-- the call to analyze them is generated when the full list is
-- analyzed.
- when
- N_SCIL_Dispatch_Table_Tag_Init |
- N_SCIL_Dispatching_Call |
- N_SCIL_Membership_Test =>
+ when N_SCIL_Dispatch_Table_Tag_Init |
+ N_SCIL_Dispatching_Call |
+ N_SCIL_Membership_Test =>
null;
-- For the remaining node types, we generate compiler abort, because
-- node appears only in the context of a type declaration, and is
-- processed by the analyze routine for type declarations.
- when
- N_Abortable_Part |
- N_Access_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition |
- N_Access_To_Object_Definition |
- N_Case_Expression_Alternative |
- N_Case_Statement_Alternative |
- N_Compilation_Unit_Aux |
- N_Component_Association |
- N_Component_Clause |
- N_Component_Definition |
- N_Component_List |
- N_Constrained_Array_Definition |
- N_Decimal_Fixed_Point_Definition |
- N_Defining_Character_Literal |
- N_Defining_Identifier |
- N_Defining_Operator_Symbol |
- N_Defining_Program_Unit_Name |
- N_Delta_Constraint |
- N_Derived_Type_Definition |
- N_Designator |
- N_Digits_Constraint |
- N_Discriminant_Association |
- N_Discriminant_Specification |
- N_Elsif_Part |
- N_Entry_Call_Statement |
- N_Enumeration_Type_Definition |
- N_Exception_Handler |
- N_Floating_Point_Definition |
- N_Formal_Decimal_Fixed_Point_Definition |
- N_Formal_Derived_Type_Definition |
- N_Formal_Discrete_Type_Definition |
- N_Formal_Floating_Point_Definition |
- N_Formal_Modular_Type_Definition |
- N_Formal_Ordinary_Fixed_Point_Definition |
- N_Formal_Private_Type_Definition |
- N_Formal_Signed_Integer_Type_Definition |
- N_Function_Specification |
- N_Generic_Association |
- N_Index_Or_Discriminant_Constraint |
- N_Iteration_Scheme |
- N_Loop_Parameter_Specification |
- N_Mod_Clause |
- N_Modular_Type_Definition |
- N_Ordinary_Fixed_Point_Definition |
- N_Parameter_Specification |
- N_Pragma_Argument_Association |
- N_Procedure_Specification |
- N_Real_Range_Specification |
- N_Record_Definition |
- N_Signed_Integer_Type_Definition |
- N_Unconstrained_Array_Definition |
- N_Unused_At_Start |
- N_Unused_At_End |
- N_Variant =>
-
+ when N_Abortable_Part |
+ N_Access_Definition |
+ N_Access_Function_Definition |
+ N_Access_Procedure_Definition |
+ N_Access_To_Object_Definition |
+ N_Aspect_Specification |
+ N_Case_Expression_Alternative |
+ N_Case_Statement_Alternative |
+ N_Compilation_Unit_Aux |
+ N_Component_Association |
+ N_Component_Clause |
+ N_Component_Definition |
+ N_Component_List |
+ N_Constrained_Array_Definition |
+ N_Contract |
+ N_Decimal_Fixed_Point_Definition |
+ N_Defining_Character_Literal |
+ N_Defining_Identifier |
+ N_Defining_Operator_Symbol |
+ N_Defining_Program_Unit_Name |
+ N_Delta_Constraint |
+ N_Derived_Type_Definition |
+ N_Designator |
+ N_Digits_Constraint |
+ N_Discriminant_Association |
+ N_Discriminant_Specification |
+ N_Elsif_Part |
+ N_Entry_Call_Statement |
+ N_Enumeration_Type_Definition |
+ N_Exception_Handler |
+ N_Floating_Point_Definition |
+ N_Formal_Decimal_Fixed_Point_Definition |
+ N_Formal_Derived_Type_Definition |
+ N_Formal_Discrete_Type_Definition |
+ N_Formal_Floating_Point_Definition |
+ N_Formal_Modular_Type_Definition |
+ N_Formal_Ordinary_Fixed_Point_Definition |
+ N_Formal_Private_Type_Definition |
+ N_Formal_Incomplete_Type_Definition |
+ N_Formal_Signed_Integer_Type_Definition |
+ N_Function_Specification |
+ N_Generic_Association |
+ N_Index_Or_Discriminant_Constraint |
+ N_Iteration_Scheme |
+ N_Mod_Clause |
+ N_Modular_Type_Definition |
+ N_Ordinary_Fixed_Point_Definition |
+ N_Parameter_Specification |
+ N_Pragma_Argument_Association |
+ N_Procedure_Specification |
+ N_Real_Range_Specification |
+ N_Record_Definition |
+ N_Signed_Integer_Type_Definition |
+ N_Unconstrained_Array_Definition |
+ N_Unused_At_Start |
+ N_Unused_At_End |
+ N_Variant =>
raise Program_Error;
end case;
then
Expand (N);
end if;
+
+ -- Restore the original Ghost mode once analysis and expansion have
+ -- taken place.
+
+ Ghost_Mode := GM;
end Analyze;
-- Version with check(s) suppressed
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Array := Scope_Suppress;
+ Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin
- Scope_Suppress := (others => True);
+ Scope_Suppress.Suppress := (others => True);
Analyze (N);
- Scope_Suppress := Svg;
+ Scope_Suppress.Suppress := Svs;
end;
- else
+ elsif Suppress = Overflow_Check then
declare
- Svg : constant Boolean := Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
- Scope_Suppress (Suppress) := True;
+ Scope_Suppress.Suppress (Suppress) := True;
Analyze (N);
- Scope_Suppress (Suppress) := Svg;
+ Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Analyze;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Array := Scope_Suppress;
+ Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin
- Scope_Suppress := (others => True);
+ Scope_Suppress.Suppress := (others => True);
Analyze_List (L);
- Scope_Suppress := Svg;
+ Scope_Suppress.Suppress := Svs;
end;
else
declare
- Svg : constant Boolean := Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
- Scope_Suppress (Suppress) := True;
+ Scope_Suppress.Suppress (Suppress) := True;
Analyze_List (L);
- Scope_Suppress (Suppress) := Svg;
+ Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Analyze_List;
return;
end if;
- -- First search the local entity suppress stack, we search this in
- -- reverse order so that we get the innermost entry that applies to
- -- this case if there are nested entries. Note that for the purpose
- -- of this procedure we are ONLY looking for entries corresponding
- -- to a two-argument Suppress, where the second argument matches From.
+ -- First search the global entity suppress table for a matching entry.
+ -- We also search this in reverse order so that if there are multiple
+ -- pragmas for the same entity, the last one applies.
Search_Stack (Global_Suppress_Stack_Top, Found);
return;
end if;
- -- Now search the global entity suppress table for a matching entry.
- -- We also search this in reverse order so that if there are multiple
- -- pragmas for the same entity, the last one applies.
+ -- Now search the local entity suppress stack, we search this in
+ -- reverse order so that we get the innermost entry that applies to
+ -- this case if there are nested entries. Note that for the purpose
+ -- of this procedure we are ONLY looking for entries corresponding
+ -- to a two-argument Suppress, where the second argument matches From.
Search_Stack (Local_Suppress_Stack_Top, Found);
end Copy_Suppress_Status;
else
Scop := Scope (E);
-
while Present (Scop) loop
if Scop = Outer_Generic_Scope then
return False;
-- of the compiler (in the normal case this loop does nothing).
while Suppress_Stack_Entries /= null loop
- Next := Global_Suppress_Stack_Top.Next;
+ Next := Suppress_Stack_Entries.Next;
Free (Suppress_Stack_Entries);
Suppress_Stack_Entries := Next;
end loop;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Array := Scope_Suppress;
+ Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin
- Scope_Suppress := (others => True);
+ Scope_Suppress.Suppress := (others => True);
Insert_After_And_Analyze (N, M);
- Scope_Suppress := Svg;
+ Scope_Suppress.Suppress := Svs;
end;
else
declare
- Svg : constant Boolean := Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
- Scope_Suppress (Suppress) := True;
+ Scope_Suppress.Suppress (Suppress) := True;
Insert_After_And_Analyze (N, M);
- Scope_Suppress (Suppress) := Svg;
+ Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_After_And_Analyze;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Array := Scope_Suppress;
+ Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin
- Scope_Suppress := (others => True);
+ Scope_Suppress.Suppress := (others => True);
Insert_Before_And_Analyze (N, M);
- Scope_Suppress := Svg;
+ Scope_Suppress.Suppress := Svs;
end;
else
declare
- Svg : constant Boolean := Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
- Scope_Suppress (Suppress) := True;
+ Scope_Suppress.Suppress (Suppress) := True;
Insert_Before_And_Analyze (N, M);
- Scope_Suppress (Suppress) := Svg;
+ Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_Before_And_Analyze;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Array := Scope_Suppress;
+ Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin
- Scope_Suppress := (others => True);
+ Scope_Suppress.Suppress := (others => True);
Insert_List_After_And_Analyze (N, L);
- Scope_Suppress := Svg;
+ Scope_Suppress.Suppress := Svs;
end;
else
declare
- Svg : constant Boolean := Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
- Scope_Suppress (Suppress) := True;
+ Scope_Suppress.Suppress (Suppress) := True;
Insert_List_After_And_Analyze (N, L);
- Scope_Suppress (Suppress) := Svg;
+ Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_List_After_And_Analyze;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Array := Scope_Suppress;
+ Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin
- Scope_Suppress := (others => True);
+ Scope_Suppress.Suppress := (others => True);
Insert_List_Before_And_Analyze (N, L);
- Scope_Suppress := Svg;
+ Scope_Suppress.Suppress := Svs;
end;
else
declare
- Svg : constant Boolean := Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
- Scope_Suppress (Suppress) := True;
+ Scope_Suppress.Suppress (Suppress) := True;
Insert_List_Before_And_Analyze (N, L);
- Scope_Suppress (Suppress) := Svg;
+ Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_List_Before_And_Analyze;
- -------------------------
- -- Is_Check_Suppressed --
- -------------------------
-
- function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
-
- Ptr : Suppress_Stack_Entry_Ptr;
-
- begin
- -- First search the local entity suppress stack. We search this from the
- -- top of the stack down so that we get the innermost entry that applies
- -- to this case if there are nested entries.
-
- Ptr := Local_Suppress_Stack_Top;
- while Ptr /= null loop
- if (Ptr.Entity = Empty or else Ptr.Entity = E)
- and then (Ptr.Check = All_Checks or else Ptr.Check = C)
- then
- return Ptr.Suppress;
- end if;
-
- Ptr := Ptr.Prev;
- end loop;
-
- -- Now search the global entity suppress table for a matching entry.
- -- We also search this from the top down so that if there are multiple
- -- pragmas for the same entity, the last one applies (not clear what
- -- or whether the RM specifies this handling, but it seems reasonable).
-
- Ptr := Global_Suppress_Stack_Top;
- while Ptr /= null loop
- if (Ptr.Entity = Empty or else Ptr.Entity = E)
- and then (Ptr.Check = All_Checks or else Ptr.Check = C)
- then
- return Ptr.Suppress;
- end if;
-
- Ptr := Ptr.Prev;
- end loop;
-
- -- If we did not find a matching entry, then use the normal scope
- -- suppress value after all (actually this will be the global setting
- -- since it clearly was not overridden at any point). For a predefined
- -- check, we test the specific flag. For a user defined check, we check
- -- the All_Checks flag.
-
- if C in Predefined_Check_Id then
- return Scope_Suppress (C);
- else
- return Scope_Suppress (All_Checks);
- end if;
- end Is_Check_Suppressed;
-
----------
-- Lock --
----------
Scope_Stack.Release;
end Lock;
+ ----------------
+ -- Preanalyze --
+ ----------------
+
+ procedure Preanalyze (N : Node_Id) is
+ Save_Full_Analysis : constant Boolean := Full_Analysis;
+
+ begin
+ Full_Analysis := False;
+ Expander_Mode_Save_And_Set (False);
+
+ Analyze (N);
+
+ Expander_Mode_Restore;
+ Full_Analysis := Save_Full_Analysis;
+ end Preanalyze;
+
--------------------------------------
-- Push_Global_Suppress_Stack_Entry --
--------------------------------------
Next => Suppress_Stack_Entries);
Suppress_Stack_Entries := Global_Suppress_Stack_Top;
return;
-
end Push_Global_Suppress_Stack_Entry;
-------------------------------------
---------------
procedure Semantics (Comp_Unit : Node_Id) is
-
- -- The following locations save the corresponding global flags and
- -- variables so that they can be restored on completion. This is needed
- -- so that calls to Rtsfind start with the proper default values for
- -- these variables, and also that such calls do not disturb the settings
- -- for units being analyzed at a higher level.
-
- S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
- S_Full_Analysis : constant Boolean := Full_Analysis;
- S_GNAT_Mode : constant Boolean := GNAT_Mode;
- S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
- S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
- S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
- S_New_Nodes_OK : constant Int := New_Nodes_OK;
- S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
-
- Generic_Main : constant Boolean :=
- Nkind (Unit (Cunit (Main_Unit)))
- in N_Generic_Declaration;
- -- If the main unit is generic, every compiled unit, including its
- -- context, is compiled with expansion disabled.
-
- Save_Config_Switches : Config_Switches_Type;
- -- Variable used to save values of config switches while we analyze the
- -- new unit, to be restored on exit for proper recursive behavior.
-
procedure Do_Analyze;
- -- Procedure to analyze the compilation unit. This is called more than
- -- once when the high level optimizer is activated.
+ -- Perform the analysis of the compilation unit
----------------
-- Do_Analyze --
----------------
procedure Do_Analyze is
+ GM : constant Ghost_Mode_Type := Ghost_Mode;
+ -- Save the current Ghost mode in effect in case the compilation unit
+ -- is withed from a unit with a different Ghost mode.
+
+ List : Elist_Id;
+
begin
- Save_Scope_Stack;
+ List := Save_Scope_Stack;
Push_Scope (Standard_Standard);
- Scope_Suppress := Suppress_Options;
+
+ -- Set up a clean environment before analyzing
+
+ Ghost_Mode := None;
+ Outer_Generic_Scope := Empty;
+ Scope_Suppress := Suppress_Options;
Scope_Stack.Table
(Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
Scope_Stack.Table
(Scope_Stack.Last).Is_Active_Stack_Base := True;
- Outer_Generic_Scope := Empty;
-- Now analyze the top level compilation unit node
-- Then pop entry for Standard, and pop implicit types
Pop_Scope;
- Restore_Scope_Stack;
+ Restore_Scope_Stack (List);
+ Ghost_Mode := GM;
end Do_Analyze;
+ -- Local variables
+
+ -- The following locations save the corresponding global flags and
+ -- variables so that they can be restored on completion. This is needed
+ -- so that calls to Rtsfind start with the proper default values for
+ -- these variables, and also that such calls do not disturb the settings
+ -- for units being analyzed at a higher level.
+
+ S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
+ S_Full_Analysis : constant Boolean := Full_Analysis;
+ S_GNAT_Mode : constant Boolean := GNAT_Mode;
+ S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
+ S_In_Assertion_Expr : constant Nat := In_Assertion_Expr;
+ S_In_Default_Expr : constant Boolean := In_Default_Expr;
+ S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
+ S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
+ S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
+ S_Style_Check : constant Boolean := Style_Check;
+
Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
+ Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit);
+ -- New value of Current_Sem_Unit
+
+ Generic_Main : constant Boolean :=
+ Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration;
+ -- If the main unit is generic, every compiled unit, including its
+ -- context, is compiled with expansion disabled.
+
+ Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean :=
+ Curunit = Main_Unit
+ or else
+ (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
+ and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit));
+ -- Configuration flags have special settings when compiling a predefined
+ -- file as a main unit. This applies to its spec as well.
+
+ Ext_Main_Source_Unit : constant Boolean :=
+ In_Extended_Main_Source_Unit (Comp_Unit);
+ -- Determine if unit is in extended main source unit
+
+ Save_Config_Switches : Config_Switches_Type;
+ -- Variable used to save values of config switches while we analyze the
+ -- new unit, to be restored on exit for proper recursive behavior.
+
+ Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions;
+ -- Used to save non-partition wide restrictions before processing new
+ -- unit. All with'ed units are analyzed with config restrictions reset
+ -- and we need to restore these saved values at the end.
+
-- Start of processing for Semantics
begin
end if;
Compiler_State := Analyzing;
- Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
+ Current_Sem_Unit := Curunit;
-- Compile predefined units with GNAT_Mode set to True, to properly
-- process the categorization stuff. However, do not set GNAT_Mode
-- Sequential_IO) as this would prevent pragma Extend_System from being
-- taken into account, for example when Text_IO is renaming DEC.Text_IO.
- -- Cleaner might be to do the kludge at the point of excluding the
- -- pragma (do not exclude for renamings ???)
-
if Is_Predefined_File_Name
(Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
then
GNAT_Mode := True;
end if;
+ -- For generic main, never do expansion
+
if Generic_Main then
Expander_Mode_Save_And_Set (False);
+
+ -- Non generic case
+
else
Expander_Mode_Save_And_Set
- (Operating_Mode = Generate_Code or Debug_Flag_X);
+
+ -- Turn on expansion if generating code
+
+ (Operating_Mode = Generate_Code
+
+ -- Or if special debug flag -gnatdx is set
+
+ or else Debug_Flag_X
+
+ -- Or if we are generating C code
+
+ or else Generate_C_Code
+
+ -- Or if in configuration run-time mode. We do this so we get
+ -- error messages about missing entities in the run-time even
+ -- if we are compiling in -gnatc (no code generation) mode.
+ -- Similar processing applies to No_Run_Time_Mode. However,
+ -- don't do this if debug flag -gnatd.Z is set or when we are
+ -- compiling a separate unit (this is to handle a situation
+ -- where this new processing causes trouble).
+
+ or else ((Configurable_Run_Time_Mode or No_Run_Time_Mode)
+ and not Debug_Flag_Dot_ZZ
+ and Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit));
end if;
Full_Analysis := True;
Inside_A_Generic := False;
+ In_Assertion_Expr := 0;
+ In_Default_Expr := False;
In_Spec_Expression := False;
-
Set_Comes_From_Source_Default (False);
+
+ -- Save current config switches and reset then appropriately
+
Save_Opt_Config_Switches (Save_Config_Switches);
Set_Opt_Config_Switches
(Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
- Current_Sem_Unit = Main_Unit);
+ Is_Main_Unit_Or_Main_Unit_Spec);
+
+ -- Save current non-partition-wide restrictions
+
+ Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save;
+
+ -- For unit in main extended unit, we reset the configuration values
+ -- for the non-partition-wide restrictions. For other units reset them.
+
+ if Ext_Main_Source_Unit then
+ Restore_Config_Cunit_Boolean_Restrictions;
+ else
+ Reset_Cunit_Boolean_Restrictions;
+ end if;
+
+ -- Turn off style checks for unit that is not in the extended main
+ -- source unit. This improves processing efficiency for such units
+ -- (for which we don't want style checks anyway, and where they will
+ -- get suppressed), and is definitely needed to stop some style checks
+ -- from invading the run-time units (e.g. overriding checks).
+
+ if not Ext_Main_Source_Unit then
+ Style_Check := False;
+
+ -- If this is part of the extended main source unit, set style check
+ -- mode to match the style check mode of the main source unit itself.
+
+ else
+ Style_Check := Style_Check_Main;
+ end if;
-- Only do analysis of unit that has not already been analyzed
if not Analyzed (Comp_Unit) then
Initialize_Version (Current_Sem_Unit);
- if HLO_Active then
- Expander_Mode_Save_And_Set (False);
- New_Nodes_OK := 1;
- Do_Analyze;
- Reset_Analyzed_Flags (Comp_Unit);
- Expander_Mode_Restore;
- High_Level_Optimize (Comp_Unit);
- New_Nodes_OK := 0;
- end if;
-- Do analysis, and then append the compilation unit onto the
- -- Comp_Unit_List, if appropriate. This is done after analysis, so
- -- if this unit depends on some others, they have already been
- -- appended. We ignore bodies, except for the main unit itself. We
- -- have also to guard against ill-formed subunits that have an
- -- improper context.
+ -- Comp_Unit_List, if appropriate. This is done after analysis,
+ -- so if this unit depends on some others, they have already been
+ -- appended. We ignore bodies, except for the main unit itself, and
+ -- for subprogram bodies that act as specs. We have also to guard
+ -- against ill-formed subunits that have an improper context.
Do_Analyze;
if Present (Comp_Unit)
and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
+ and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
+ or else not Acts_As_Spec (Comp_Unit))
and then not In_Extended_Main_Source_Unit (Comp_Unit)
then
null;
else
- -- Initialize if first time
-
- if No (Comp_Unit_List) then
- Comp_Unit_List := New_Elmt_List;
- end if;
-
- Append_Elmt (Comp_Unit, Comp_Unit_List);
+ Append_New_Elmt (Comp_Unit, To => Comp_Unit_List);
if Debug_Unit_Walk then
Write_Str ("Appending ");
Full_Analysis := S_Full_Analysis;
Global_Discard_Names := S_Global_Dis_Names;
GNAT_Mode := S_GNAT_Mode;
+ In_Assertion_Expr := S_In_Assertion_Expr;
+ In_Default_Expr := S_In_Default_Expr;
In_Spec_Expression := S_In_Spec_Expr;
Inside_A_Generic := S_Inside_A_Generic;
- New_Nodes_OK := S_New_Nodes_OK;
Outer_Generic_Scope := S_Outer_Gen_Scope;
+ Style_Check := S_Style_Check;
Restore_Opt_Config_Switches (Save_Config_Switches);
+
+ -- Deal with restore of restrictions
+
+ Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
+
Expander_Mode_Restore;
if Debug_Unit_Walk then
end if;
end Semantics;
+ --------
+ -- ss --
+ --------
+
+ function ss (Index : Int) return Scope_Stack_Entry is
+ begin
+ return Scope_Stack.Table (Index);
+ end ss;
+
+ ---------
+ -- sst --
+ ---------
+
+ function sst return Scope_Stack_Entry is
+ begin
+ return ss (Scope_Stack.Last);
+ end sst;
+
------------------------
-- Walk_Library_Items --
------------------------
-- This is needed because the spec of the main unit may appear in the
-- context of some other unit. We do not want this to force processing
-- of the main body before all other units have been processed.
+ --
+ -- Another circularity pattern occurs when the main unit is a child unit
+ -- and the body of an ancestor has a with-clause of the main unit or on
+ -- one of its children. In both cases the body in question has a with-
+ -- clause on the main unit, and must be excluded from the traversal. In
+ -- some convoluted cases this may lead to a CodePeer error because the
+ -- spec of a subprogram declared in an instance within the parent will
+ -- not be seen in the main unit.
+
+ function Depends_On_Main (CU : Node_Id) return Boolean;
+ -- The body of a unit that is withed by the spec of the main unit may in
+ -- turn have a with_clause on that spec. In that case do not traverse
+ -- the body, to prevent loops. It can also happen that the main body has
+ -- a with_clause on a child, which of course has an implicit with on its
+ -- parent. It's OK to traverse the child body if the main spec has been
+ -- processed, otherwise we also have a circularity to avoid.
procedure Do_Action (CU : Node_Id; Item : Node_Id);
-- Calls Action, with some validity checks
-- an instance spec, do the body last.
procedure Do_Withed_Unit (Withed_Unit : Node_Id);
- -- Apply Do_Unit_And_Dependents to a unit in a context clause.
+ -- Apply Do_Unit_And_Dependents to a unit in a context clause
procedure Process_Bodies_In_Context (Comp : Node_Id);
-- The main unit and its spec may depend on bodies that contain generics
-- is processed wherever it appears in the list of units, while the body
-- is processed as the last unit in the list.
+ ---------------------
+ -- Depends_On_Main --
+ ---------------------
+
+ function Depends_On_Main (CU : Node_Id) return Boolean is
+ CL : Node_Id;
+ MCU : constant Node_Id := Unit (Main_CU);
+
+ begin
+ CL := First (Context_Items (CU));
+
+ -- Problem does not arise with main subprograms
+
+ if
+ not Nkind_In (MCU, N_Package_Body, N_Package_Declaration)
+ then
+ return False;
+ end if;
+
+ while Present (CL) loop
+ if Nkind (CL) = N_With_Clause
+ and then Library_Unit (CL) = Main_CU
+ and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
+ then
+ return True;
+ end if;
+
+ Next (CL);
+ end loop;
+
+ return False;
+ end Depends_On_Main;
+
---------------
-- Do_Action --
---------------
Do_Withed_Units (CU, Include_Limited => False);
- -- Process the unit if it is a spec or the the main unit, if it
+ -- Process the unit if it is a spec or the main unit, if it
-- has no previous spec or we have done all other units.
if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
- function Depends_On_Main (CU : Node_Id) return Boolean;
- -- The body of a unit that is withed by the spec of the main unit
- -- may in turn have a with_clause on that spec. In that case do not
- -- traverse the body, to prevent loops. It can also happen that the
- -- main body has a with_clause on a child, which of course has an
- -- implicit with on its parent. It's OK to traverse the child body
- -- if the main spec has been processed, otherwise we also have a
- -- circularity to avoid.
-
- ---------------------
- -- Depends_On_Main --
- ---------------------
-
- function Depends_On_Main (CU : Node_Id) return Boolean is
- CL : Node_Id;
-
- begin
- CL := First (Context_Items (CU));
-
- -- Problem does not arise with main subprograms
-
- if Nkind (Unit (Main_CU)) /= N_Package_Body then
- return False;
- end if;
-
- while Present (CL) loop
- if Nkind (CL) = N_With_Clause
- and then Library_Unit (CL) = Library_Unit (Main_CU)
- and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
- then
- return True;
- end if;
-
- Next (CL);
- end loop;
-
- return False;
- end Depends_On_Main;
-
-- Start of processing for Process_Bodies_In_Context
begin
Cur := First_Elmt (Comp_Unit_List);
while Present (Cur) loop
declare
- CU : constant Node_Id := Node (Cur);
- N : constant Node_Id := Unit (CU);
+ CU : constant Node_Id := Node (Cur);
+ N : constant Node_Id := Unit (CU);
+ Par : Entity_Id;
begin
pragma Assert (Nkind (CU) = N_Compilation_Unit);
-- a package, the original file carries the body, and the spec
-- appears as a later entry in the units list.
- -- Otherwise Bodies appear in the list only because of inlining
- -- or instantiations, and they are processed only if relevant
- -- to the main unit. The main unit itself is processed
- -- separately after all other specs.
+ -- Otherwise bodies appear in the list only because of inlining
+ -- or instantiations, and they are processed only if relevant.
+ -- The flag Withed_Body on a context clause indicates that a
+ -- unit contains an instantiation that may be needed later,
+ -- and therefore the body that contains the generic body (and
+ -- its context) must be traversed immediately after the
+ -- corresponding spec (see Do_Unit_And_Dependents).
+
+ -- The main unit itself is processed separately after all other
+ -- specs, and relevant bodies are examined in Process_Main.
when N_Subprogram_Body =>
if Acts_As_Spec (N) then
Unit (Library_Unit (Main_CU)));
end if;
- -- It's a spec, process it, and the units it depends on
+ -- It's a spec, process it, and the units it depends on,
+ -- unless it is a descendent of the main unit. This can
+ -- happen when the body of a parent depends on some other
+ -- descendent.
when others =>
- Do_Unit_And_Dependents (CU, N);
+ Par := Scope (Defining_Entity (Unit (CU)));
+
+ if Is_Child_Unit (Defining_Entity (Unit (CU))) then
+ while Present (Par)
+ and then Par /= Standard_Standard
+ and then Par /= Cunit_Entity (Main_Unit)
+ loop
+ Par := Scope (Par);
+ end loop;
+ end if;
+
+ if Par /= Cunit_Entity (Main_Unit) then
+ Do_Unit_And_Dependents (CU, N);
+ end if;
end case;
end;
if not Done (Main_Unit) then
Do_Main := True;
- declare
+ Process_Main : declare
Parent_CU : Node_Id;
Body_CU : Node_Id;
Body_U : Unit_Number_Type;
Child : Entity_Id;
+ function Is_Subunit_Of_Main (U : Node_Id) return Boolean;
+ -- If the main unit has subunits, their context may include
+ -- bodies that are needed in the body of main. We must examine
+ -- the context of the subunits, which are otherwise not made
+ -- explicit in the main unit.
+
+ ------------------------
+ -- Is_Subunit_Of_Main --
+ ------------------------
+
+ function Is_Subunit_Of_Main (U : Node_Id) return Boolean is
+ Lib : Node_Id;
+ begin
+ if No (U) then
+ return False;
+ else
+ Lib := Library_Unit (U);
+ return Nkind (Unit (U)) = N_Subunit
+ and then
+ (Lib = Cunit (Main_Unit)
+ or else Is_Subunit_Of_Main (Lib));
+ end if;
+ end Is_Subunit_Of_Main;
+
+ -- Start of processing for Process_Main
+
begin
Process_Bodies_In_Context (Main_CU);
+ for Unit_Num in Done'Range loop
+ if Is_Subunit_Of_Main (Cunit (Unit_Num)) then
+ Process_Bodies_In_Context (Cunit (Unit_Num));
+ end if;
+ end loop;
+
-- If the main unit is a child unit, parent bodies may be present
-- because they export instances or inlined subprograms. Check for
-- presence of these, which are not present in context clauses.
if Present (Body_CU)
and then not Seen (Get_Cunit_Unit_Number (Body_CU))
+ and then not Depends_On_Main (Body_CU)
then
Body_U := Get_Cunit_Unit_Number (Body_CU);
Seen (Body_U) := True;
Do_Action (Main_CU, Unit (Main_CU));
Done (Main_Unit) := True;
- end;
+ end Process_Main;
end if;
if Debug_Unit_Walk then
pragma Assert (Nkind (CU) = N_Compilation_Unit);
Context_Item : Node_Id;
+ Lib_Unit : Node_Id;
+ Body_CU : Node_Id;
begin
Context_Item := First (Context_Items (CU));
and then (Include_Limited
or else not Limited_Present (Context_Item))
then
- Action (Library_Unit (Context_Item));
+ Lib_Unit := Library_Unit (Context_Item);
+ Action (Lib_Unit);
+
+ -- If the context item indicates that a package body is needed
+ -- because of an instantiation in CU, traverse the body now, even
+ -- if CU is not related to the main unit. If the generic itself
+ -- appears in a package body, the context item is this body, and
+ -- it already appears in the traversal order, so we only need to
+ -- examine the case of a context item being a package declaration.
+
+ if Present (Withed_Body (Context_Item))
+ and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration
+ and then Present (Corresponding_Body (Unit (Lib_Unit)))
+ then
+ Body_CU :=
+ Parent
+ (Unit_Declaration_Node
+ (Corresponding_Body (Unit (Lib_Unit))));
+
+ -- A body may have an implicit with on its own spec, in which
+ -- case we must ignore this context item to prevent looping.
+
+ if Unit (CU) /= Unit (Body_CU) then
+ Action (Body_CU);
+ end if;
+ end if;
end if;
Context_Item := Next (Context_Item);
end loop;
end Walk_Withs_Immediate;
- ---------------------
- -- Write_Unit_Info --
- ---------------------
-
- procedure Write_Unit_Info
- (Unit_Num : Unit_Number_Type;
- Item : Node_Id;
- Prefix : String := "";
- Withs : Boolean := False)
- is
- begin
- Write_Str (Prefix);
- Write_Unit_Name (Unit_Name (Unit_Num));
- Write_Str (", unit ");
- Write_Int (Int (Unit_Num));
- Write_Str (", ");
- Write_Int (Int (Item));
- Write_Str ("=");
- Write_Str (Node_Kind'Image (Nkind (Item)));
-
- if Item /= Original_Node (Item) then
- Write_Str (", orig = ");
- Write_Int (Int (Original_Node (Item)));
- Write_Str ("=");
- Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
- end if;
-
- Write_Eol;
-
- -- Skip the rest if we're not supposed to print the withs
-
- if not Withs then
- return;
- end if;
-
- declare
- Context_Item : Node_Id;
-
- begin
- Context_Item := First (Context_Items (Cunit (Unit_Num)));
- while Present (Context_Item)
- and then (Nkind (Context_Item) /= N_With_Clause
- or else Limited_Present (Context_Item))
- loop
- Context_Item := Next (Context_Item);
- end loop;
-
- if Present (Context_Item) then
- Indent;
- Write_Line ("withs:");
- Indent;
-
- while Present (Context_Item) loop
- if Nkind (Context_Item) = N_With_Clause
- and then not Limited_Present (Context_Item)
- then
- pragma Assert (Present (Library_Unit (Context_Item)));
- Write_Unit_Name
- (Unit_Name
- (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
-
- if Implicit_With (Context_Item) then
- Write_Str (" -- implicit");
- end if;
-
- Write_Eol;
- end if;
-
- Context_Item := Next (Context_Item);
- end loop;
-
- Outdent;
- Write_Line ("end withs");
- Outdent;
- end if;
- end;
- end Write_Unit_Info;
-
end Sem;
projects / gcc.git / blobdiff