OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Rename parameter of routines in Checks 

2020-06-05  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* checks.ads (Apply_Length_Check): Rename Ck_Node parameter to
	Expr.
	(Apply_Range_Check): Likewise.
	(Get_Range_Checks): Likewise.
	* checks.adb (Apply_Float_Conversion_Check): Likewise.
	(Apply_Selected_Length_Checks): Likewise.
	(Apply_Selected_Range_Checks): Likewise.
	(Guard_Access): Likewise.
	(Selected_Length_Checks): Likewise.  Also avoid shadowing in
	child procedures.
	(Selected_Range_Checks): Likewise.
This commit is contained in:
Eric Botcazou 2020-01-30 13:23:31 +01:00 committed by Pierre-Marie de Rodat
parent a4c17870b8
commit 6c8e70fe86
2 changed files with 132 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

258
gcc/ada/checks.adb
View File

@ -223,7 +223,7 @@ package body Checks is
-- can be referenced and trusted only if ROK is set True.
procedure Apply_Float_Conversion_Check
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id);
-- The checks on a conversion from a floating-point type to an integer
-- type are delicate. They have to be performed before conversion, they
@ -231,7 +231,7 @@ package body Checks is
-- be taken into account to determine the safe bounds of the operand.
procedure Apply_Selected_Length_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean);
@ -241,7 +241,7 @@ package body Checks is
-- only a static check is to be done.
procedure Apply_Selected_Range_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean);
@ -307,9 +307,9 @@ package body Checks is
-- To be cleaned up???
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
Ck_Node : Node_Id) return Node_Id;
(Cond : Node_Id;
Loc : Source_Ptr;
Expr : Node_Id) return Node_Id;
-- In the access type case, guard the test with a test to ensure
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
@ -332,7 +332,7 @@ package body Checks is
-- of an entity, if these checks are suppressed for the entity.
function Selected_Length_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result;
@ -345,7 +345,7 @@ package body Checks is
-- Selected_Range_Checks.
function Selected_Range_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result;
@ -1999,17 +1999,17 @@ package body Checks is
-- Hi_OK be True.
procedure Apply_Float_Conversion_Check
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id)
is
LB : constant Node_Id := Type_Low_Bound (Target_Typ);
HB : constant Node_Id := Type_High_Bound (Target_Typ);
Loc : constant Source_Ptr := Sloc (Ck_Node);
Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
Loc : constant Source_Ptr := Sloc (Expr);
Expr_Type : constant Entity_Id := Base_Type (Etype (Expr));
Target_Base : constant Entity_Id :=
Implementation_Base_Type (Target_Typ);
Par : constant Node_Id := Parent (Ck_Node);
Par : constant Node_Id := Parent (Expr);
pragma Assert (Nkind (Par) = N_Type_Conversion);
-- Parent of check node, must be a type conversion
@ -2049,7 +2049,7 @@ package body Checks is
-- set the Do_Range check flag, since the range check is taken care of
-- by the code we will generate.
Set_Do_Range_Check (Ck_Node, False);
Set_Do_Range_Check (Expr, False);
if not Compile_Time_Known_Value (LB)
or not Compile_Time_Known_Value (HB)
@ -2064,7 +2064,7 @@ package body Checks is
Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
begin
Apply_Float_Conversion_Check (Ck_Node, Target_Base);
Apply_Float_Conversion_Check (Expr, Target_Base);
Set_Etype (Temp, Target_Base);
-- Note: Previously the declaration was inserted above the parent
@ -2105,21 +2105,21 @@ package body Checks is
-- we can do the comparison with the bounds and the conversion to
-- an integer type statically. The range checks are unchanged.
if Nkind (Ck_Node) = N_Real_Literal
and then Etype (Ck_Node) = Universal_Real
if Nkind (Expr) = N_Real_Literal
and then Etype (Expr) = Universal_Real
and then Is_Integer_Type (Target_Typ)
then
declare
Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
Int_Val : constant Uint := UR_To_Uint (Realval (Expr));
begin
if Int_Val <= Ilast and then Int_Val >= Ifirst then
-- Conversion is safe
Rewrite (Parent (Ck_Node),
Rewrite (Parent (Expr),
Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
Analyze_And_Resolve (Parent (Expr), Target_Typ);
return;
end if;
end;
@ -2140,7 +2140,7 @@ package body Checks is
Lo_OK := (Ifirst > 0);
else
Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Expr);
Lo_OK := (Lo >= UR_From_Uint (Ifirst));
end if;
@ -2149,14 +2149,14 @@ package body Checks is
-- Lo_Chk := (X >= Lo)
Lo_Chk := Make_Op_Ge (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Lo));
else
-- Lo_Chk := (X > Lo)
Lo_Chk := Make_Op_Gt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Lo));
end if;
@ -2174,7 +2174,7 @@ package body Checks is
Hi := UR_From_Uint (Ilast) + Ureal_Half;
Hi_OK := (Ilast < 0);
else
Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Expr);
Hi_OK := (Hi <= UR_From_Uint (Ilast));
end if;
@ -2183,14 +2183,14 @@ package body Checks is
-- Hi_Chk := (X <= Hi)
Hi_Chk := Make_Op_Le (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Hi));
else
-- Hi_Chk := (X < Hi)
Hi_Chk := Make_Op_Lt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Hi));
end if;
@ -2208,7 +2208,7 @@ package body Checks is
-- Raise CE if either conditions does not hold
Insert_Action (Ck_Node,
Insert_Action (Expr,
Make_Raise_Constraint_Error (Loc,
Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
Reason => Reason));
@ -2219,13 +2219,13 @@ package body Checks is
------------------------
procedure Apply_Length_Check
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty)
is
begin
Apply_Selected_Length_Checks
(Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
(Expr, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Length_Check;
-------------------------------------
@ -2853,13 +2853,13 @@ package body Checks is
-----------------------
procedure Apply_Range_Check
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty)
is
begin
Apply_Selected_Range_Checks
(Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
(Expr, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Range_Check;
------------------------------
@ -3263,7 +3263,7 @@ package body Checks is
----------------------------------
procedure Apply_Selected_Length_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean)
@ -3273,7 +3273,7 @@ package body Checks is
or else
not Length_Checks_Suppressed (Target_Typ);
Loc : constant Source_Ptr := Sloc (Ck_Node);
Loc : constant Source_Ptr := Sloc (Expr);
Cond : Node_Id;
R_Cno : Node_Id;
@ -3290,7 +3290,7 @@ package body Checks is
end if;
R_Result :=
Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
Selected_Length_Checks (Expr, Target_Typ, Source_Typ, Empty);
for J in 1 .. 2 loop
R_Cno := R_Result (J);
@ -3304,13 +3304,13 @@ package body Checks is
if Ekind (Current_Scope) = E_Package
and then Is_Compilation_Unit (Current_Scope)
then
Ensure_Defined (Target_Typ, Ck_Node);
Ensure_Defined (Target_Typ, Expr);
if Present (Source_Typ) then
Ensure_Defined (Source_Typ, Ck_Node);
Ensure_Defined (Source_Typ, Expr);
elsif Is_Itype (Etype (Ck_Node)) then
Ensure_Defined (Etype (Ck_Node), Ck_Node);
elsif Is_Itype (Etype (Expr)) then
Ensure_Defined (Etype (Expr), Expr);
end if;
end if;
@ -3324,15 +3324,15 @@ package body Checks is
-- Case where node does not now have a dynamic check
if not Has_Dynamic_Length_Check (Ck_Node) then
if not Has_Dynamic_Length_Check (Expr) then
-- If checks are on, just insert the check
if Checks_On then
Insert_Action (Ck_Node, R_Cno);
Insert_Action (Expr, R_Cno);
if not Do_Static then
Set_Has_Dynamic_Length_Check (Ck_Node);
Set_Has_Dynamic_Length_Check (Expr);
end if;
-- If checks are off, then analyze the length check after
@ -3341,7 +3341,7 @@ package body Checks is
-- compile time warning in this case.
else
Set_Parent (R_Cno, Ck_Node);
Set_Parent (R_Cno, Expr);
Analyze (R_Cno);
end if;
end if;
@ -3352,7 +3352,7 @@ package body Checks is
and then Entity (Cond) = Standard_True
then
Apply_Compile_Time_Constraint_Error
(Ck_Node, "wrong length for array of}??",
(Expr, "wrong length for array of}??",
CE_Length_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
@ -3377,7 +3377,7 @@ package body Checks is
---------------------------------
procedure Apply_Selected_Range_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean)
@ -3387,7 +3387,7 @@ package body Checks is
or else
not Range_Checks_Suppressed (Target_Typ);
Loc : constant Source_Ptr := Sloc (Ck_Node);
Loc : constant Source_Ptr := Sloc (Expr);
Cond : Node_Id;
R_Cno : Node_Id;
@ -3406,7 +3406,7 @@ package body Checks is
end if;
R_Result :=
Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Empty);
if GNATprove_Mode then
return;
@ -3428,14 +3428,14 @@ package body Checks is
-- Insert the range check before the related context. Note that
-- this action analyses the triggering condition.
Insert_Action (Ck_Node, R_Cno);
Insert_Action (Expr, R_Cno);
-- This old code doesn't make sense, why is the context flagged as
-- requiring dynamic range checks now in the middle of generating
-- them ???
if not Do_Static then
Set_Has_Dynamic_Range_Check (Ck_Node);
Set_Has_Dynamic_Range_Check (Expr);
end if;
-- The triggering condition evaluates to True, the range check
@ -3449,19 +3449,19 @@ package body Checks is
-- N_Range. The warning message will point to the lower bound
-- and complain about a range, which seems OK.
if Nkind (Ck_Node) = N_Range then
if Nkind (Expr) = N_Range then
Apply_Compile_Time_Constraint_Error
(Low_Bound (Ck_Node),
(Low_Bound (Expr),
"static range out of bounds of}??",
CE_Range_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
Set_Raises_Constraint_Error (Ck_Node);
Set_Raises_Constraint_Error (Expr);
else
Apply_Compile_Time_Constraint_Error
(Ck_Node,
(Expr,
"static value out of range of}??",
CE_Range_Check_Failed,
Ent => Target_Typ,
@ -7358,14 +7358,14 @@ package body Checks is
----------------------
function Get_Range_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
Warn_Node : Node_Id := Empty) return Check_Result
is
begin
return
Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Warn_Node);
end Get_Range_Checks;
------------------
@ -7373,16 +7373,16 @@ package body Checks is
------------------
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
Ck_Node : Node_Id) return Node_Id
(Cond : Node_Id;
Loc : Source_Ptr;
Expr : Node_Id) return Node_Id
is
begin
if Nkind (Cond) = N_Or_Else then
Set_Paren_Count (Cond, 1);
end if;
if Nkind (Ck_Node) = N_Allocator then
if Nkind (Expr) = N_Allocator then
return Cond;
else
@ -7390,7 +7390,7 @@ package body Checks is
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
@ -9555,12 +9555,12 @@ package body Checks is
----------------------------
function Selected_Length_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
Loc : constant Source_Ptr := Sloc (Expr);
S_Typ : Entity_Id;
T_Typ : Entity_Id;
Expr_Actual : Node_Id;
@ -9592,11 +9592,11 @@ package body Checks is
-- Typ'Length /= Exptyp'Length
function Length_N_Cond
(Expr : Node_Id;
(Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Typ'Length /= Expr'Length
-- Typ'Length /= Exp'Length
function Length_Mismatch_Info_Message
(Left_Element_Count : Uint;
@ -9641,7 +9641,7 @@ package body Checks is
N := Build_Discriminal_Subtype_Of_Component (E);
if Present (N) then
Insert_Action (Ck_Node, N);
Insert_Action (Expr, N);
E1 := Defining_Identifier (N);
end if;
end if;
@ -9780,7 +9780,7 @@ package body Checks is
-------------------
function Length_N_Cond
(Expr : Node_Id;
(Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id
is
@ -9788,7 +9788,7 @@ package body Checks is
return
Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (Typ, Indx),
Right_Opnd => Get_N_Length (Expr, Indx));
Right_Opnd => Get_N_Length (Exp, Indx));
end Length_N_Cond;
----------------------------------
@ -9868,19 +9868,19 @@ package body Checks is
if Target_Typ = Any_Type
or else Target_Typ = Any_Composite
or else Raises_Constraint_Error (Ck_Node)
or else Raises_Constraint_Error (Expr)
then
return Ret_Result;
end if;
if No (Wnode) then
Wnode := Ck_Node;
Wnode := Expr;
end if;
T_Typ := Target_Typ;
if No (Source_Typ) then
S_Typ := Etype (Ck_Node);
S_Typ := Etype (Expr);
else
S_Typ := Source_Typ;
end if;
@ -9896,7 +9896,7 @@ package body Checks is
-- A simple optimization for the null case
if Known_Null (Ck_Node) then
if Known_Null (Expr) then
return Ret_Result;
end if;
end if;
@ -9909,10 +9909,10 @@ package body Checks is
-- freeze node does not appear within the generated if expression,
-- but ahead of it.
Freeze_Before (Ck_Node, T_Typ);
Freeze_Before (Expr, T_Typ);
Expr_Actual := Get_Referenced_Object (Ck_Node);
Exptyp := Get_Actual_Subtype (Ck_Node);
Expr_Actual := Get_Referenced_Object (Expr);
Exptyp := Get_Actual_Subtype (Expr);
if Is_Access_Type (Exptyp) then
Exptyp := Designated_Type (Exptyp);
@ -9972,9 +9972,9 @@ package body Checks is
not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
and then In_Open_Scopes (Scope (Exptyp))
then
Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
Ref_Node := Make_Itype_Reference (Sloc (Expr));
Set_Itype (Ref_Node, Exptyp);
Insert_Action (Ck_Node, Ref_Node);
Insert_Action (Expr, Ref_Node);
end if;
L_Index := First_Index (T_Typ);
@ -10058,7 +10058,7 @@ package body Checks is
-- the length or range from the expression itself, making sure we
-- do not evaluate it more than once.
-- Here Ck_Node is the original expression, or more properly the
-- Here Expr is the original expression, or more properly the
-- result of applying Duplicate_Expr to the original tree, forcing
-- the result to be a name.
@ -10071,7 +10071,7 @@ package body Checks is
for Indx in 1 .. Ndims loop
Evolve_Or_Else
(Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
(Cond, Length_N_Cond (Expr, T_Typ, Indx));
end loop;
end;
end if;
@ -10082,7 +10082,7 @@ package body Checks is
if Present (Cond) then
if Do_Access then
Cond := Guard_Access (Cond, Loc, Ck_Node);
Cond := Guard_Access (Cond, Loc, Expr);
end if;
Add_Check
@ -10099,12 +10099,12 @@ package body Checks is
---------------------------
function Selected_Range_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
Loc : constant Source_Ptr := Sloc (Expr);
S_Typ : Entity_Id;
T_Typ : Entity_Id;
Expr_Actual : Node_Id;
@ -10119,20 +10119,20 @@ package body Checks is
-- Adds the action given to Ret_Result if N is non-Empty
function Discrete_Range_Cond
(Expr : Node_Id;
Typ : Entity_Id) return Node_Id;
(Exp : Node_Id;
Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Low_Bound (Expr) < Typ'First
-- Low_Bound (Exp) < Typ'First
-- or else
-- High_Bound (Expr) > Typ'Last
-- High_Bound (Exp) > Typ'Last
function Discrete_Expr_Cond
(Expr : Node_Id;
Typ : Entity_Id) return Node_Id;
(Exp : Node_Id;
Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Expr < Typ'First
-- Exp < Typ'First
-- or else
-- Expr > Typ'Last
-- Exp > Typ'Last
function Get_E_First_Or_Last
(Loc : Source_Ptr;
@ -10169,11 +10169,11 @@ package body Checks is
-- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
function Range_N_Cond
(Expr : Node_Id;
(Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id;
-- Return expression to compute:
-- Expr'First < Typ'First or else Expr'Last > Typ'Last
-- Exp'First < Typ'First or else Exp'Last > Typ'Last
---------------
-- Add_Check --
@ -10200,8 +10200,8 @@ package body Checks is
-------------------------
function Discrete_Expr_Cond
(Expr : Node_Id;
Typ : Entity_Id) return Node_Id
(Exp : Node_Id;
Typ : Entity_Id) return Node_Id
is
begin
return
@ -10210,7 +10210,7 @@ package body Checks is
Make_Op_Lt (Loc,
Left_Opnd =>
Convert_To (Base_Type (Typ),
Duplicate_Subexpr_No_Checks (Expr)),
Duplicate_Subexpr_No_Checks (Exp)),
Right_Opnd =>
Convert_To (Base_Type (Typ),
Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
@ -10219,7 +10219,7 @@ package body Checks is
Make_Op_Gt (Loc,
Left_Opnd =>
Convert_To (Base_Type (Typ),
Duplicate_Subexpr_No_Checks (Expr)),
Duplicate_Subexpr_No_Checks (Exp)),
Right_Opnd =>
Convert_To
(Base_Type (Typ),
@ -10231,11 +10231,11 @@ package body Checks is
-------------------------
function Discrete_Range_Cond
(Expr : Node_Id;
Typ : Entity_Id) return Node_Id
(Exp : Node_Id;
Typ : Entity_Id) return Node_Id
is
LB : Node_Id := Low_Bound (Expr);
HB : Node_Id := High_Bound (Expr);
LB : Node_Id := Low_Bound (Exp);
HB : Node_Id := High_Bound (Exp);
Left_Opnd : Node_Id;
Right_Opnd : Node_Id;
@ -10391,7 +10391,7 @@ package body Checks is
------------------
function Range_N_Cond
(Expr : Node_Id;
(Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id
is
@ -10401,14 +10401,14 @@ package body Checks is
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd =>
Get_N_First (Expr, Indx),
Get_N_First (Exp, Indx),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd =>
Get_N_Last (Expr, Indx),
Get_N_Last (Exp, Indx),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_N_Cond;
@ -10427,19 +10427,19 @@ package body Checks is
if Target_Typ = Any_Type
or else Target_Typ = Any_Composite
or else Raises_Constraint_Error (Ck_Node)
or else Raises_Constraint_Error (Expr)
then
return Ret_Result;
end if;
if No (Wnode) then
Wnode := Ck_Node;
Wnode := Expr;
end if;
T_Typ := Target_Typ;
if No (Source_Typ) then
S_Typ := Etype (Ck_Node);
S_Typ := Etype (Expr);
else
S_Typ := Source_Typ;
end if;
@ -10449,7 +10449,7 @@ package body Checks is
end if;
-- The order of evaluating T_Typ before S_Typ seems to be critical
-- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
-- because S_Typ can be derived from Etype (Expr), if it's not passed
-- in, and since Node can be an N_Range node, it might be invalid.
-- Should there be an assert check somewhere for taking the Etype of
-- an N_Range node ???
@ -10461,7 +10461,7 @@ package body Checks is
-- A simple optimization for the null case
if Known_Null (Ck_Node) then
if Known_Null (Expr) then
return Ret_Result;
end if;
end if;
@ -10469,11 +10469,11 @@ package body Checks is
-- For an N_Range Node, check for a null range and then if not
-- null generate a range check action.
if Nkind (Ck_Node) = N_Range then
if Nkind (Expr) = N_Range then
-- There's no point in checking a range against itself
if Ck_Node = Scalar_Range (T_Typ) then
if Expr = Scalar_Range (T_Typ) then
return Ret_Result;
end if;
@ -10483,8 +10483,8 @@ package body Checks is
Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
LB : Node_Id := Low_Bound (Ck_Node);
HB : Node_Id := High_Bound (Ck_Node);
LB : Node_Id := Low_Bound (Expr);
HB : Node_Id := High_Bound (Expr);
Known_LB : Boolean := False;
Known_HB : Boolean := False;
@ -10568,7 +10568,7 @@ package body Checks is
if No (Warn_Node) then
Add_Check
(Compile_Time_Constraint_Error
(Low_Bound (Ck_Node),
(Low_Bound (Expr),
"static value out of range of}??", T_Typ));
else
@ -10583,7 +10583,7 @@ package body Checks is
if No (Warn_Node) then
Add_Check
(Compile_Time_Constraint_Error
(High_Bound (Ck_Node),
(High_Bound (Expr),
"static value out of range of}??", T_Typ));
else
@ -10597,8 +10597,8 @@ package body Checks is
else
declare
LB : Node_Id := Low_Bound (Ck_Node);
HB : Node_Id := High_Bound (Ck_Node);
LB : Node_Id := Low_Bound (Expr);
HB : Node_Id := High_Bound (Expr);
begin
-- If either bound is a discriminant and we are within the
@ -10641,7 +10641,7 @@ package body Checks is
end if;
end if;
Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
Cond := Discrete_Range_Cond (Expr, T_Typ);
Set_Paren_Count (Cond, 1);
Cond :=
@ -10668,7 +10668,7 @@ package body Checks is
-- arbitrary target type, so we do that here.
if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
Cond := Discrete_Expr_Cond (Expr, T_Typ);
-- For literals, we can tell if the constraint error will be
-- raised at compile time, so we never need a dynamic check, but
@ -10676,7 +10676,7 @@ package body Checks is
-- and replace the literal with a raise constraint error
-- expression. As usual, skip this for access types
elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then
elsif Compile_Time_Known_Value (Expr) and then not Do_Access then
declare
LB : constant Node_Id := Type_Low_Bound (T_Typ);
UB : constant Node_Id := Type_High_Bound (T_Typ);
@ -10692,17 +10692,17 @@ package body Checks is
if Static_Bounds then
if Is_Floating_Point_Type (S_Typ) then
Out_Of_Range :=
(Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
(Expr_Value_R (Expr) < Expr_Value_R (LB))
or else
(Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
(Expr_Value_R (Expr) > Expr_Value_R (UB));
-- Fixed or discrete type
else
Out_Of_Range :=
Expr_Value (Ck_Node) < Expr_Value (LB)
Expr_Value (Expr) < Expr_Value (LB)
or else
Expr_Value (Ck_Node) > Expr_Value (UB);
Expr_Value (Expr) > Expr_Value (UB);
end if;
-- Bounds of the type are static and the literal is out of
@ -10712,7 +10712,7 @@ package body Checks is
if No (Warn_Node) then
Add_Check
(Compile_Time_Constraint_Error
(Ck_Node,
(Expr,
"static value out of range of}??", T_Typ));
else
@ -10724,7 +10724,7 @@ package body Checks is
end if;
else
Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
Cond := Discrete_Expr_Cond (Expr, T_Typ);
end if;
end;
@ -10734,7 +10734,7 @@ package body Checks is
else
if not In_Subrange_Of (S_Typ, T_Typ) then
Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
Cond := Discrete_Expr_Cond (Expr, T_Typ);
end if;
end if;
end if;
@ -10742,7 +10742,7 @@ package body Checks is
if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
if Is_Constrained (T_Typ) then
Expr_Actual := Get_Referenced_Object (Ck_Node);
Expr_Actual := Get_Referenced_Object (Expr);
Exptyp := Get_Actual_Subtype (Expr_Actual);
if Is_Access_Type (Exptyp) then
@ -10817,7 +10817,7 @@ package body Checks is
-- the length or range from the expression itself, making sure we
-- do not evaluate it more than once.
-- Here Ck_Node is the original expression, or more properly the
-- Here Expr is the original expression, or more properly the
-- result of applying Duplicate_Expr to the original tree,
-- forcing the result to be a name.
@ -10830,7 +10830,7 @@ package body Checks is
for Indx in 1 .. Ndims loop
Evolve_Or_Else
(Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
(Cond, Range_N_Cond (Expr, T_Typ, Indx));
end loop;
end;
end if;
@ -10843,7 +10843,7 @@ package body Checks is
-- array type, as 4.6(24.15/2) requires the designated subtypes
-- of the two access types to statically match.
if Nkind (Parent (Ck_Node)) = N_Type_Conversion
if Nkind (Parent (Expr)) = N_Type_Conversion
and then not Do_Access
then
declare
@ -10852,7 +10852,7 @@ package body Checks is
Opnd_Range : Node_Id;
begin
Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
Opnd_Index := First_Index (Get_Actual_Subtype (Expr));
Targ_Index := First_Index (T_Typ);
while Present (Opnd_Index) loop
@ -10923,7 +10923,7 @@ package body Checks is
if Present (Cond) then
if Do_Access then
Cond := Guard_Access (Cond, Loc, Ck_Node);
Cond := Guard_Access (Cond, Loc, Expr);
end if;
Add_Check

12
gcc/ada/checks.ads
View File

@ -526,12 +526,6 @@ package Checks is
-- this node is further examined depends on the setting of
-- the parameter Source_Typ, as described below.
-- ??? Apply_Length_Check and Apply_Range_Check do not have an Expr
-- formal
-- ??? Apply_Length_Check and Apply_Range_Check have a Ck_Node formal
-- which is undocumented, is it the same as Expr?
-- Target_Typ The target type on which the check is to be based. For
-- example, if we have a scalar range check, then the check
-- is that we are in range of this type.
@ -558,7 +552,7 @@ package Checks is
-- handled by the caller.
procedure Apply_Length_Check
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty);
-- This procedure builds a sequence of declarations to do a length check
@ -576,7 +570,7 @@ package Checks is
-- in this section.
procedure Apply_Range_Check
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty);
-- For a Node of kind N_Range, constructs a range check action that tests
@ -628,7 +622,7 @@ package Checks is
-- call to Insert_Range_Checks procedure.
function Get_Range_Checks
(Ck_Node : Node_Id;
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
Warn_Node : Node_Id := Empty) return Check_Result;