-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- 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. --
+-- 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 Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
with Fname; use Fname;
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;
return;
end if;
- Current_Error_Node := N;
-
-- Otherwise processing depends on the node kind
case Nkind (N) is
when N_Explicit_Dereference =>
Analyze_Explicit_Dereference (N);
+ when N_Extended_Return_Statement =>
+ Analyze_Extended_Return_Statement (N);
+
when N_Extension_Aggregate =>
Analyze_Aggregate (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
when N_Error =>
null;
+ -- Push/Pop nodes normally don't come through an analyze call. An
+ -- exception is the dummy ones bracketing a subprogram body. In any
+ -- case there is nothing to be done to analyze such nodes.
+
+ when N_Push_Pop_xxx_Label =>
+ 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
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 |
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.
+ -- Now that we have analyzed the node, we call the expander to perform
+ -- possible expansion. We skip this for subexpressions, because 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 Sem_Res.Resolve. A special exception is Raise_xxx_Error,
+ -- which can appear in a statement context, and needs expanding now in
+ -- the case (distinguished by Etype, as documented in Sinfo).
-- 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
+ -- nodes (in the case of subexpression nodes, we can't set the flag yet,
+ -- since resolution and expansion have not yet been completed). Note
+ -- that for N_Raise_xxx_Error we have to distinguish the expression
+ -- case from the statement case.
+
+ if Nkind (N) not in N_Subexpr
+ or else (Nkind (N) in N_Raise_xxx_Error
+ and then Etype (N) = Standard_Void_Type)
+ then
Expand (N);
end if;
-
end Analyze;
-- Version with check(s) suppressed
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze (N);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze (N);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Analyze;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze_List (L);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_List (L);
- Set_Scope_Suppress (Suppress, Svg);
+ 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 --
-------------------------
if S = Outer_Generic_Scope then
Outer_Generic_Scope := Empty;
end if;
- end Exit_Generic_Scope;
+ 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
- begin
+ 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.
+ -- is in a different compilation unit, or it is defined within a unit
+ -- in the same compilation, that is not within the outer_generic.
- 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;
+ if No (Outer_Generic_Scope) then
+ return False;
- ------------------------
- -- Get_Scope_Suppress --
- ------------------------
+ elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
+ or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
+ then
+ return True;
- function Get_Scope_Suppress (C : Check_Id) return Boolean is
- S : Suppress_Record renames Scope_Suppress;
+ 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;
- 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;
+ return True;
+ end if;
+ end External_Ref_In_Generic;
----------------
-- Initialize --
procedure Initialize is
begin
- Entity_Suppress.Init;
+ Local_Entity_Suppress.Init;
+ Global_Entity_Suppress.Init;
Scope_Stack.Init;
Unloaded_Subunits := False;
end Initialize;
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)
+ (N : Node_Id;
+ M : Node_Id;
+ Suppress : Check_Id)
is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Insert_After_And_Analyze (N, M);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_After_And_Analyze (N, M);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_After_And_Analyze;
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)
+ (N : Node_Id;
+ M : Node_Id;
+ Suppress : Check_Id)
is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Insert_Before_And_Analyze (N, M);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_Before_And_Analyze (N, M);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_Before_And_Analyze;
Next (Node);
end loop;
end if;
-
end Insert_List_After_And_Analyze;
-- Version with check(s) suppressed
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Insert_List_After_And_Analyze (N, L);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_List_After_And_Analyze (N, L);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_List_After_And_Analyze;
Next (Node);
end loop;
end if;
-
end Insert_List_Before_And_Analyze;
-- Version with check(s) suppressed
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Insert_List_Before_And_Analyze (N, L);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_List_Before_And_Analyze (N, L);
- Set_Scope_Suppress (Suppress, Svg);
+ 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
- Entity_Suppress.Locked := True;
+ Local_Entity_Suppress.Locked := True;
+ Global_Entity_Suppress.Locked := True;
Scope_Stack.Locked := True;
- Entity_Suppress.Release;
+ Local_Entity_Suppress.Release;
+ Global_Entity_Suppress.Release;
Scope_Stack.Release;
end Lock;
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;
+ S_Discard_Names : constant Boolean := Global_Discard_Names;
+ 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
-- 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);
+ Push_Scope (Standard_Standard);
Scope_Suppress := Suppress_Options;
Scope_Stack.Table
(Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
Restore_Scope_Stack;
end Do_Analyze;
- -- Start of processing for Sem
+ -- Start of processing for Semantics
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);
+ 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;
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)));
+ (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
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;
+ Global_Discard_Names := S_Discard_Names;
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;
OSDN Git Service
