-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Freeze; use Freeze;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
+with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Case; use Sem_Case;
with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
procedure Analyze_Iteration_Scheme (N : Node_Id);
+ procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id);
+ -- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme
+ -- (the latter when a WHILE condition is present). This call checks
+ -- if Condition (Cnode) is of the form ([NOT] var op val), where var
+ -- is a simple object, val is known at compile time, and op is one
+ -- of the six relational operators. If this is the case, and the
+ -- Current_Value field of "var" is not set, then it is set to Cnode.
+ -- See Exp_Util.Set_Current_Value_Condition for further details.
+
------------------------
-- Analyze_Assignment --
------------------------
procedure Analyze_Assignment (N : Node_Id) is
- Lhs : constant Node_Id := Name (N);
- Rhs : constant Node_Id := Expression (N);
- T1, T2 : Entity_Id;
- Decl : Node_Id;
+ Lhs : constant Node_Id := Name (N);
+ Rhs : constant Node_Id := Expression (N);
+ T1 : Entity_Id;
+ T2 : Entity_Id;
+ Decl : Node_Id;
+ Ent : Entity_Id;
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
-- N is the node for the left hand side of an assignment, and it
-- Some special bad cases of entity names
elsif Is_Entity_Name (N) then
-
if Ekind (Entity (N)) = E_In_Parameter then
Error_Msg_N
("assignment to IN mode parameter not allowed", N);
- return;
-- Private declarations in a protected object are turned into
-- constants when compiling a protected function.
then
Error_Msg_N
("protected function cannot modify protected object", N);
- return;
elsif Ekind (Entity (N)) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
- return;
+ else
+ Error_Msg_N
+ ("left hand side of assignment must be a variable", N);
end if;
- -- For indexed components, or selected components, test prefix
+ -- For indexed components or selected components, test prefix
- elsif Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Selected_Component
- then
+ elsif Nkind (N) = N_Indexed_Component then
Diagnose_Non_Variable_Lhs (Prefix (N));
- return;
- end if;
- -- If we fall through, we have no special message to issue!
+ -- Another special case for assignment to discriminant.
+
+ elsif Nkind (N) = N_Selected_Component then
+ if Present (Entity (Selector_Name (N)))
+ and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
+ then
+ Error_Msg_N
+ ("assignment to discriminant not allowed", N);
+ else
+ Diagnose_Non_Variable_Lhs (Prefix (N));
+ end if;
- Error_Msg_N ("left hand side of assignment must be a variable", N);
+ else
+ -- If we fall through, we have no special message to issue!
+ Error_Msg_N ("left hand side of assignment must be a variable", N);
+ end if;
end Diagnose_Non_Variable_Lhs;
-------------------------
Opnd_Type : in out Entity_Id)
is
begin
+ Require_Entity (Opnd);
+
-- If the assignment operand is an in-out or out parameter, then we
-- get the actual subtype (needed for the unconstrained case).
+ -- If the operand is the actual in an entry declaration, then within
+ -- the accept statement it is replaced with a local renaming, which
+ -- may also have an actual subtype.
if Is_Entity_Name (Opnd)
and then (Ekind (Entity (Opnd)) = E_Out_Parameter
or else Ekind (Entity (Opnd)) =
E_In_Out_Parameter
or else Ekind (Entity (Opnd)) =
- E_Generic_In_Out_Parameter)
+ E_Generic_In_Out_Parameter
+ or else
+ (Ekind (Entity (Opnd)) = E_Variable
+ and then Nkind (Parent (Entity (Opnd))) =
+ N_Object_Renaming_Declaration
+ and then Nkind (Parent (Parent (Entity (Opnd)))) =
+ N_Accept_Statement))
then
Opnd_Type := Get_Actual_Subtype (Opnd);
-- If assignment operand is a component reference, then we get the
-- actual subtype of the component for the unconstrained case.
- elsif Nkind (Opnd) = N_Selected_Component
- or else Nkind (Opnd) = N_Explicit_Dereference
+ elsif
+ (Nkind (Opnd) = N_Selected_Component
+ or else Nkind (Opnd) = N_Explicit_Dereference)
+ and then not Is_Unchecked_Union (Opnd_Type)
then
Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
while Present (It.Typ) loop
if Has_Compatible_Type (Rhs, It.Typ) then
-
if T1 /= Any_Type then
-- An explicit dereference is overloaded if the prefix
Get_First_Interp (Prefix (Lhs), PI, PIt);
while Present (PIt.Typ) loop
- if Has_Compatible_Type (Rhs,
- Designated_Type (PIt.Typ))
+ if Is_Access_Type (PIt.Typ)
+ and then Has_Compatible_Type
+ (Rhs, Designated_Type (PIt.Typ))
then
if Found then
PIt :=
PI1, PI, Any_Type);
if PIt = No_Interp then
- return;
+ Error_Msg_N
+ ("ambiguous left-hand side"
+ & " in assignment", Lhs);
+ exit;
else
Resolve (Prefix (Lhs), PIt.Typ);
end if;
then
Error_Msg_N
("left hand of assignment must not be limited type", Lhs);
+ Explain_Limited_Type (T1, Lhs);
return;
end if;
Set_Assignment_Type (Lhs, T1);
Resolve (Rhs, T1);
+ Check_Unset_Reference (Rhs);
- -- Remaining steps are skipped if Rhs was synatactically in error
+ -- Remaining steps are skipped if Rhs was syntactically in error
if Rhs = Error then
return;
end if;
T2 := Etype (Rhs);
- Check_Unset_Reference (Rhs);
- Note_Possible_Modification (Lhs);
if Covers (T1, T2) then
null;
Set_Assignment_Type (Rhs, T2);
+ if Total_Errors_Detected /= 0 then
+ if No (T1) then
+ T1 := Any_Type;
+ end if;
+
+ if No (T2) then
+ T2 := Any_Type;
+ end if;
+ end if;
+
if T1 = Any_Type or else T2 = Any_Type then
return;
end if;
Propagate_Tag (Lhs, Rhs);
end if;
+ -- Ada 2005 (AI-231)
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Rhs) = N_Null
+ and then Is_Access_Type (T1)
+ and then not Assignment_OK (Lhs)
+ and then ((Is_Entity_Name (Lhs)
+ and then Can_Never_Be_Null (Entity (Lhs)))
+ or else Can_Never_Be_Null (Etype (Lhs)))
+ then
+ Error_Msg_N
+ ("(Ada 2005) NULL not allowed in null-excluding objects", Lhs);
+ end if;
+
if Is_Scalar_Type (T1) then
Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
- elsif Is_Array_Type (T1) then
-
+ elsif Is_Array_Type (T1)
+ and then
+ (Nkind (Rhs) /= N_Type_Conversion
+ or else Is_Constrained (Etype (Rhs)))
+ then
-- Assignment verifies that the length of the Lsh and Rhs are equal,
- -- but of course the indices do not have to match.
+ -- but of course the indices do not have to match. If the right-hand
+ -- side is a type conversion to an unconstrained type, a length check
+ -- is performed on the expression itself during expansion. In rare
+ -- cases, the redundant length check is computed on an index type
+ -- with a different representation, triggering incorrect code in
+ -- the back end.
Apply_Length_Check (Rhs, Etype (Lhs));
else
- -- Discriminant checks are applied in the course of expansion.
+ -- Discriminant checks are applied in the course of expansion
+
null;
end if;
+ -- Note: modifications of the Lhs may only be recorded after
+ -- checks have been applied.
+
+ Note_Possible_Modification (Lhs);
+
-- ??? a real accessibility check is needed when ???
-- Post warning for useless assignment
-- Where the entity is the same on both sides
and then Is_Entity_Name (Lhs)
- and then Is_Entity_Name (Rhs)
- and then Entity (Lhs) = Entity (Rhs)
+ and then Is_Entity_Name (Original_Node (Rhs))
+ and then Entity (Lhs) = Entity (Original_Node (Rhs))
-- But exclude the case where the right side was an operation
-- that got rewritten (e.g. JUNK + K, where K was known to be
Error_Msg_NE
("?useless assignment of & to itself", N, Entity (Lhs));
end if;
+
+ -- Check for non-allowed composite assignment
+
+ if not Support_Composite_Assign_On_Target
+ and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
+ and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
+ then
+ Error_Msg_CRT ("composite assignment", N);
+ end if;
+
+ -- One more step. Let's see if we have a simple assignment of a
+ -- known at compile time value to a simple variable. If so, we
+ -- can record the value as the current value providing that:
+
+ -- We still have a simple assignment statement (no expansion
+ -- activity has modified it in some peculiar manner)
+
+ -- The type is a discrete type
+
+ -- The assignment is to a named entity
+
+ -- The value is known at compile time
+
+ if Nkind (N) /= N_Assignment_Statement
+ or else not Is_Discrete_Type (T1)
+ or else not Is_Entity_Name (Lhs)
+ or else not Compile_Time_Known_Value (Rhs)
+ then
+ return;
+ end if;
+
+ Ent := Entity (Lhs);
+
+ -- Capture value if save to do so
+
+ if Safe_To_Capture_Value (N, Ent) then
+ Set_Current_Value (Ent, Rhs);
+ end if;
end Analyze_Assignment;
-----------------------------
procedure Analyze_Block_Statement (N : Node_Id) is
Decls : constant List_Id := Declarations (N);
Id : constant Node_Id := Identifier (N);
- Ent : Entity_Id;
+ Ent : Entity_Id := Empty;
begin
-- If a label is present analyze it and mark it as referenced
if Present (Id) then
Analyze (Id);
Ent := Entity (Id);
- Set_Ekind (Ent, E_Block);
- Generate_Reference (Ent, N, ' ');
- Generate_Definition (Ent);
- if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
- Set_Label_Construct (Parent (Ent), N);
+ -- An error defense. If we have an identifier, but no entity, then
+ -- something is wrong. If we have previous errors, then just remove
+ -- the identifier and continue, otherwise raise an exception.
+
+ if No (Ent) then
+ if Total_Errors_Detected /= 0 then
+ Set_Identifier (N, Empty);
+ else
+ raise Program_Error;
+ end if;
+
+ else
+ Set_Ekind (Ent, E_Block);
+ Generate_Reference (Ent, N, ' ');
+ Generate_Definition (Ent);
+
+ if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Ent), N);
+ end if;
end if;
+ end if;
- -- Otherwise create a label entity
+ -- If no entity set, create a label entity
- else
+ if No (Ent) then
Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
+ Set_Parent (Ent, N);
end if;
Set_Etype (Ent, Standard_Void_Type);
- Set_Block_Node (Ent, N);
+ Set_Block_Node (Ent, Identifier (N));
New_Scope (Ent);
if Present (Decls) then
end if;
Analyze (Handled_Statement_Sequence (N));
- Process_End_Label (Handled_Statement_Sequence (N), 'e');
+ Process_End_Label (Handled_Statement_Sequence (N), 'e', Ent);
-- Analyze exception handlers if present. Note that the test for
-- HSS being present is an error defence against previous errors.
Set_Has_Nested_Block_With_Handler (S);
exit when Is_Overloadable (S)
or else Ekind (S) = E_Package
- or else Ekind (S) = E_Generic_Function
- or else Ekind (S) = E_Generic_Package
- or else Ekind (S) = E_Generic_Procedure;
+ or else Is_Generic_Unit (S);
S := Scope (S);
end loop;
end;
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Statements);
use Case_Choices_Processing;
- -- Instantiation of the generic choice processing package.
+ -- Instantiation of the generic choice processing package
-----------------------------
-- Non_Static_Choice_Error --
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
- Error_Msg_N ("choice given in case statement is not static", Choice);
+ Flag_Non_Static_Expr
+ ("choice given in case statement is not static!", Choice);
end Non_Static_Choice_Error;
------------------------
("character literal as case expression is ambiguous", Exp);
return;
- elsif Ada_83
+ elsif Ada_Version = Ada_83
and then (Is_Generic_Type (Exp_Btype)
or else Is_Generic_Type (Root_Type (Exp_Btype)))
then
return;
end if;
- -- If the case expression is a formal object of mode in out,
- -- then treat it as having a nonstatic subtype by forcing
- -- use of the base type (which has to get passed to
- -- Check_Case_Choices below). Also use base type when
- -- the case expression is parenthesized.
+ -- If the case expression is a formal object of mode in out, then
+ -- treat it as having a nonstatic subtype by forcing use of the base
+ -- type (which has to get passed to Check_Case_Choices below). Also
+ -- use base type when the case expression is parenthesized.
if Paren_Count (Exp) > 0
or else (Is_Entity_Name (Exp)
Exp_Type := Exp_Btype;
end if;
- -- Call the instantiated Analyze_Choices which does the rest of the work
+ -- Call instantiated Analyze_Choices which does the rest of the work
Analyze_Choices
(N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
else
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
+
+ if not Expander_Active
+ and then Compile_Time_Known_Value (Expression (N))
+ and then Serious_Errors_Detected = 0
+ then
+ declare
+ Chosen : constant Node_Id := Find_Static_Alternative (N);
+ Alt : Node_Id;
+
+ begin
+ Alt := First (Alternatives (N));
+
+ while Present (Alt) loop
+ if Alt /= Chosen then
+ Remove_Warning_Messages (Statements (Alt));
+ end if;
+
+ Next (Alt);
+ end loop;
+ end;
+ end if;
end Analyze_Case_Statement;
----------------------------
end if;
end loop;
- -- Verify that if present the condition is a Boolean expression.
+ -- Verify that if present the condition is a Boolean expression
if Present (Cond) then
Analyze_And_Resolve (Cond, Any_Boolean);
end loop;
raise Program_Error;
-
end Analyze_Goto_Statement;
--------------------------
--------------------------
-- A special complication arises in the analysis of if statements.
- -- The expander has circuitry to completely deleted code that it
+
+ -- The expander has circuitry to completely delete code that it
-- can tell will not be executed (as a result of compile time known
-- conditions). In the analyzer, we ensure that code that will be
-- deleted in this manner is analyzed but not expanded. This is
-- obviously more efficient, but more significantly, difficulties
-- arise if code is expanded and then eliminated (e.g. exception
- -- table entries disappear).
+ -- table entries disappear). Similarly, itypes generated in deleted
+ -- code must be frozen from start, because the nodes on which they
+ -- depend will not be available at the freeze point.
procedure Analyze_If_Statement (N : Node_Id) is
E : Node_Id;
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
-- Recursively save value of this global, will be restored on exit
+ Save_In_Deleted_Code : Boolean;
+
Del : Boolean := False;
-- This flag gets set True if a True condition has been found,
-- which means that remaining ELSE/ELSIF parts are deleted.
-- to an N_Elsif_Part node. It deals with analyzing the condition
-- and the THEN statements associated with it.
+ -----------------------
+ -- Analyze_Cond_Then --
+ -----------------------
+
procedure Analyze_Cond_Then (Cnode : Node_Id) is
Cond : constant Node_Id := Condition (Cnode);
Tstm : constant List_Id := Then_Statements (Cnode);
Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
Analyze_And_Resolve (Cond, Any_Boolean);
Check_Unset_Reference (Cond);
+ Check_Possible_Current_Value_Condition (Cnode);
-- If already deleting, then just analyze then statements
-- Compile time known value, not deleting yet
elsif Compile_Time_Known_Value (Cond) then
+ Save_In_Deleted_Code := In_Deleted_Code;
-- If condition is True, then analyze the THEN statements
-- and set no expansion for ELSE and ELSIF parts.
Analyze_Statements (Tstm);
Del := True;
Expander_Mode_Save_And_Set (False);
+ In_Deleted_Code := True;
-- If condition is False, analyze THEN with expansion off
else -- Is_False (Expr_Value (Cond))
Expander_Mode_Save_And_Set (False);
+ In_Deleted_Code := True;
Analyze_Statements (Tstm);
Expander_Mode_Restore;
+ In_Deleted_Code := Save_In_Deleted_Code;
end if;
-- Not known at compile time, not deleting, normal analysis
if Del then
Expander_Mode_Restore;
+ In_Deleted_Code := Save_In_Deleted_Code;
end if;
+ if not Expander_Active
+ and then Compile_Time_Known_Value (Condition (N))
+ and then Serious_Errors_Detected = 0
+ then
+ if Is_True (Expr_Value (Condition (N))) then
+ Remove_Warning_Messages (Else_Statements (N));
+
+ if Present (Elsif_Parts (N)) then
+ E := First (Elsif_Parts (N));
+
+ while Present (E) loop
+ Remove_Warning_Messages (Then_Statements (E));
+ Next (E);
+ end loop;
+ end if;
+
+ else
+ Remove_Warning_Messages (Then_Statements (N));
+ end if;
+ end if;
end Analyze_If_Statement;
----------------------------------------
-- Analyze_Label_Entity.
procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
- Id : Node_Id := Defining_Identifier (N);
-
+ Id : constant Node_Id := Defining_Identifier (N);
begin
- Enter_Name (Id);
+ Enter_Name (Id);
Set_Ekind (Id, E_Label);
Set_Etype (Id, Standard_Void_Type);
Set_Enclosing_Scope (Id, Current_Scope);
------------------------------
procedure Analyze_Iteration_Scheme (N : Node_Id) is
+ procedure Check_Controlled_Array_Attribute (DS : Node_Id);
+ -- If the bounds are given by a 'Range reference on a function call
+ -- that returns a controlled array, introduce an explicit declaration
+ -- to capture the bounds, so that the function result can be finalized
+ -- in timely fashion.
+
+ --------------------------------------
+ -- Check_Controlled_Array_Attribute --
+ --------------------------------------
+
+ procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
+ begin
+ if Nkind (DS) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (DS))
+ and then Ekind (Entity (Prefix (DS))) = E_Function
+ and then Is_Array_Type (Etype (Entity (Prefix (DS))))
+ and then
+ Is_Controlled (
+ Component_Type (Etype (Entity (Prefix (DS)))))
+ and then Expander_Active
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Arr : constant Entity_Id :=
+ Etype (Entity (Prefix (DS)));
+ Indx : constant Entity_Id :=
+ Base_Type (Etype (First_Index (Arr)));
+ Subt : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('S'));
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Indx, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Relocate_Node (DS))));
+ Insert_Before (Parent (N), Decl);
+ Analyze (Decl);
+
+ Rewrite (DS,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Subt, Loc),
+ Attribute_Name => Attribute_Name (DS)));
+ Analyze (DS);
+ end;
+ end if;
+ end Check_Controlled_Array_Attribute;
+
+ -- Start of processing for Analyze_Iteration_Scheme
+
begin
-- For an infinite loop, there is no iteration scheme
LP : constant Node_Id := Loop_Parameter_Specification (N);
Id : constant Entity_Id := Defining_Identifier (LP);
DS : constant Node_Id := Discrete_Subtype_Definition (LP);
- F : List_Id;
begin
Enter_Name (Id);
declare
H : constant Entity_Id := Homonym (Id);
-
begin
if Present (H)
and then Enclosing_Dynamic_Scope (H) =
Set_Etype (DS, Any_Type);
end if;
+ Check_Controlled_Array_Attribute (DS);
Make_Index (DS, LP);
Set_Ekind (Id, E_Loop_Parameter);
Set_Is_Known_Valid (Id, True);
-- The loop is not a declarative part, so the only entity
- -- declared "within" must be frozen explicitly. Since the
- -- type of this entity has already been frozen, this cannot
- -- generate any freezing actions.
+ -- declared "within" must be frozen explicitly.
- F := Freeze_Entity (Id, Sloc (LP));
- pragma Assert (F = No_List);
+ declare
+ Flist : constant List_Id := Freeze_Entity (Id, Sloc (N));
+ begin
+ if Is_Non_Empty_List (Flist) then
+ Insert_Actions (N, Flist);
+ end if;
+ end;
-- Check for null or possibly null range and issue warning.
-- We suppress such messages in generic templates and
if Nkind (DS) = N_Range
and then Comes_From_Source (N)
- and then not Inside_A_Generic
- and then not In_Instance
then
declare
L : constant Node_Id := Low_Bound (DS);
-- If range of loop is null, issue warning
if (LOK and HOK) and then Llo > Hhi then
- Error_Msg_N
- ("?loop range is null, loop will not execute",
- DS);
+
+ -- Suppress the warning if inside a generic
+ -- template or instance, since in practice
+ -- they tend to be dubious in these cases since
+ -- they can result from intended parametrization.
+
+ if not Inside_A_Generic
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("?loop range is null, loop will not execute",
+ DS);
+ end if;
+
+ -- Since we know the range of the loop is null,
+ -- set the appropriate flag to suppress any
+ -- warnings that would otherwise be issued in
+ -- the body of the loop that will not execute.
+ -- We do this even in the generic case, since
+ -- if it is dubious to warn on the null loop
+ -- itself, it is certainly dubious to warn for
+ -- conditions that occur inside it!
+
+ Set_Is_Null_Loop (Parent (N));
-- The other case for a warning is a reverse loop
-- where the upper bound is the integer literal
-- zero or one, and the lower bound can be positive.
+ -- For example, we have
+
+ -- for J in reverse N .. 1 loop
+
+ -- In practice, this is very likely to be a case
+ -- of reversing the bounds incorrectly in the range.
+
elsif Reverse_Present (LP)
and then Nkind (H) = N_Integer_Literal
and then (Intval (H) = Uint_0
Intval (H) = Uint_1)
and then Lhi > Hhi
then
- Warn_On_Instance := True;
Error_Msg_N ("?loop range may be null", DS);
- Warn_On_Instance := False;
end if;
end;
end if;
-- Analyze_Label --
-------------------
- -- Important note: normally this routine is called from Analyze_Statements
- -- which does a prescan, to make sure that the Reachable flags are set on
- -- all labels before encountering a possible goto to one of these labels.
- -- If expanded code analyzes labels via the normal Sem path, then it must
- -- ensure that Reachable is set early enough to avoid problems in the case
- -- of a forward goto.
+ -- Note: the semantic work required for analyzing labels (setting them as
+ -- reachable) was done in a prepass through the statements in the block,
+ -- so that forward gotos would be properly handled. See Analyze_Statements
+ -- for further details. The only processing required here is to deal with
+ -- optimizations that depend on an assumption of sequential control flow,
+ -- since of course the occurrence of a label breaks this assumption.
procedure Analyze_Label (N : Node_Id) is
- Lab : Entity_Id;
-
+ pragma Warnings (Off, N);
begin
- Analyze (Identifier (N));
- Lab := Entity (Identifier (N));
-
- -- If we found a label mark it as reachable.
-
- if Ekind (Lab) = E_Label then
- Generate_Definition (Lab);
- Set_Reachable (Lab);
-
- if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
- Set_Label_Construct (Parent (Lab), N);
- end if;
-
- -- If we failed to find a label, it means the implicit declaration
- -- of the label was hidden. A for-loop parameter can do this to a
- -- label with the same name inside the loop, since the implicit label
- -- declaration is in the innermost enclosing body or block statement.
-
- else
- Error_Msg_Sloc := Sloc (Lab);
- Error_Msg_N
- ("implicit label declaration for & is hidden#",
- Identifier (N));
- end if;
+ Kill_Current_Values;
end Analyze_Label;
--------------------------
Set_Parent (Ent, N);
end if;
+ -- Kill current values on entry to loop, since statements in body
+ -- of loop may have been executed before the loop is entered.
+ -- Similarly we kill values after the loop, since we do not know
+ -- that the body of the loop was executed.
+
+ Kill_Current_Values;
New_Scope (Ent);
Analyze_Iteration_Scheme (Iteration_Scheme (N));
Analyze_Statements (Statements (N));
- Process_End_Label (N, 'e');
+ Process_End_Label (N, 'e', Ent);
End_Scope;
+ Kill_Current_Values;
end Analyze_Loop_Statement;
----------------------------
-- null statement, too bad everything isn't as simple as this!
procedure Analyze_Null_Statement (N : Node_Id) is
+ pragma Warnings (Off, N);
begin
null;
end Analyze_Null_Statement;
------------------------
procedure Analyze_Statements (L : List_Id) is
- S : Node_Id;
+ S : Node_Id;
+ Lab : Entity_Id;
begin
-- The labels declared in the statement list are reachable from
-- reachable. This is not required, but is nice behavior!
S := First (L);
-
while Present (S) loop
if Nkind (S) = N_Label then
- Analyze_Label (S);
+ Analyze (Identifier (S));
+ Lab := Entity (Identifier (S));
+
+ -- If we found a label mark it as reachable.
+
+ if Ekind (Lab) = E_Label then
+ Generate_Definition (Lab);
+ Set_Reachable (Lab);
+
+ if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Lab), S);
+ end if;
+
+ -- If we failed to find a label, it means the implicit declaration
+ -- of the label was hidden. A for-loop parameter can do this to
+ -- a label with the same name inside the loop, since the implicit
+ -- label declaration is in the innermost enclosing body or block
+ -- statement.
+
+ else
+ Error_Msg_Sloc := Sloc (Lab);
+ Error_Msg_N
+ ("implicit label declaration for & is hidden#",
+ Identifier (S));
+ end if;
end if;
Next (S);
-- Perform semantic analysis on all statements
- S := First (L);
+ Conditional_Statements_Begin;
+ S := First (L);
while Present (S) loop
-
- if Nkind (S) /= N_Label then
- Analyze (S);
- end if;
-
+ Analyze (S);
Next (S);
end loop;
+ Conditional_Statements_End;
+
-- Make labels unreachable. Visibility is not sufficient, because
-- labels in one if-branch for example are not reachable from the
-- other branch, even though their declarations are in the enclosing
-- declarative part.
S := First (L);
-
while Present (S) loop
if Nkind (S) = N_Label then
Set_Reachable (Entity (Identifier (S)), False);
end loop;
end Analyze_Statements;
+ --------------------------------------------
+ -- Check_Possible_Current_Value_Condition --
+ --------------------------------------------
+
+ procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id) is
+ Cond : Node_Id;
+
+ begin
+ -- Loop to deal with (ignore for now) any NOT operators present
+
+ Cond := Condition (Cnode);
+ while Nkind (Cond) = N_Op_Not loop
+ Cond := Right_Opnd (Cond);
+ end loop;
+
+ -- Check possible relational operator
+
+ if Nkind (Cond) = N_Op_Eq
+ or else
+ Nkind (Cond) = N_Op_Ne
+ or else
+ Nkind (Cond) = N_Op_Ge
+ or else
+ Nkind (Cond) = N_Op_Le
+ or else
+ Nkind (Cond) = N_Op_Gt
+ or else
+ Nkind (Cond) = N_Op_Lt
+ then
+ if Compile_Time_Known_Value (Right_Opnd (Cond))
+ and then Nkind (Left_Opnd (Cond)) = N_Identifier
+ then
+ declare
+ Ent : constant Entity_Id := Entity (Left_Opnd (Cond));
+
+ begin
+ if Ekind (Ent) = E_Variable
+ or else
+ Ekind (Ent) = E_Constant
+ or else
+ Is_Formal (Ent)
+ or else
+ Ekind (Ent) = E_Loop_Parameter
+ then
+ -- Here we have a case where the Current_Value field
+ -- may need to be set. We set it if it is not already
+ -- set to a compile time expression value.
+
+ -- Note that this represents a decision that one
+ -- condition blots out another previous one. That's
+ -- certainly right if they occur at the same level.
+ -- If the second one is nested, then the decision is
+ -- neither right nor wrong (it would be equally OK
+ -- to leave the outer one in place, or take the new
+ -- inner one. Really we should record both, but our
+ -- data structures are not that elaborate.
+
+ if Nkind (Current_Value (Ent)) not in N_Subexpr then
+ Set_Current_Value (Ent, Cnode);
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+ end Check_Possible_Current_Value_Condition;
+
----------------------------
-- Check_Unreachable_Code --
----------------------------
if Operating_Mode = Generate_Code then
loop
Nxt := Next (N);
- exit when No (Nxt) or else not Is_Statement (Nxt);
+
+ -- Quit deleting when we have nothing more to delete
+ -- or if we hit a label (since someone could transfer
+ -- control to a label, so we should not delete it).
+
+ exit when No (Nxt) or else Nkind (Nxt) = N_Label;
+
+ -- Statement/declaration is to be deleted
+
Analyze (Nxt);
Remove (Nxt);
Kill_Dead_Code (Nxt);
OSDN Git Service
