-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 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- --
with Exp_Ch2; use Exp_Ch2;
with Exp_Util; use Exp_Util;
with Elists; use Elists;
+with Eval_Fat; use Eval_Fat;
with Freeze; use Freeze;
with Lib; use Lib;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
-- Local Subprograms --
-----------------------
+ procedure Apply_Float_Conversion_Check
+ (Ck_Node : 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
+ -- have to raise an exception when the operand is a NaN, and rounding must
+ -- be taken into account to determine the safe bounds of the operand.
+
procedure Apply_Selected_Length_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
- Ck_Node : Node_Id)
- return Node_Id;
+ Ck_Node : 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.
+ procedure Install_Null_Excluding_Check (N : Node_Id);
+ -- Determines whether an access node requires a runtime access check and
+ -- if so inserts the appropriate run-time check
+
procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
-- Constraint_Error node.
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result;
+ Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Length_Checks, except it doesn't modify
-- anything, just returns a list of nodes as described in the spec of
-- this package for the Range_Check function.
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result;
+ Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
-- just returns a list of nodes as described in the spec of this package
-- for the Range_Check function.
-- Access check is required
- declare
- Loc : constant Source_Ptr := Sloc (N);
-
- begin
- Insert_Action (N,
- Make_Raise_Constraint_Error (Sloc (N),
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr_Move_Checks (P),
- Right_Opnd =>
- Make_Null (Loc)),
- Reason => CE_Access_Check_Failed));
- end;
+ Install_Null_Excluding_Check (P);
end Apply_Access_Check;
-------------------------------
Reason => PE_Misaligned_Address_Value));
Error_Msg_NE
("?specified address for& not " &
- "consistent with alignment", Expr, E);
+ "consistent with alignment ('R'M 13.3(27))", Expr, E);
end if;
-- Here we do not know if the value is acceptable, generate
else
-- Skip generation of this code if we don't want elab code
- if not Restrictions (No_Elaboration_Code) then
+ if not Restriction_Active (No_Elaboration_Code) then
Insert_After_And_Analyze (N,
Make_Raise_Program_Error (Loc,
Condition =>
then
Apply_Discriminant_Check (N, Typ);
end if;
+
+ if Can_Never_Be_Null (Typ)
+ and then not Can_Never_Be_Null (Etype (N))
+ then
+ Install_Null_Excluding_Check (N);
+ end if;
end if;
end Apply_Constraint_Check;
end if;
end Apply_Divide_Check;
+ ----------------------------------
+ -- Apply_Float_Conversion_Check --
+ ----------------------------------
+
+ -- Let F and I be the source and target types of the conversion.
+ -- The Ada standard specifies that a floating-point value X is rounded
+ -- to the nearest integer, with halfway cases being rounded away from
+ -- zero. The rounded value of X is checked against I'Range.
+
+ -- The catch in the above paragraph is that there is no good way
+ -- to know whether the round-to-integer operation resulted in
+ -- overflow. A remedy is to perform a range check in the floating-point
+ -- domain instead, however:
+ -- (1) The bounds may not be known at compile time
+ -- (2) The check must take into account possible rounding.
+ -- (3) The range of type I may not be exactly representable in F.
+ -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
+ -- not be in range, depending on the sign of I'First and I'Last.
+ -- (5) X may be a NaN, which will fail any comparison
+
+ -- The following steps take care of these issues converting X:
+ -- (1) If either I'First or I'Last is not known at compile time, use
+ -- I'Base instead of I in the next three steps and perform a
+ -- regular range check against I'Range after conversion.
+ -- (2) If I'First - 0.5 is representable in F then let Lo be that
+ -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
+ -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
+ -- take one of the closest floating-point numbers to T, and see if
+ -- it is in range or not.
+ -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
+ -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
+ -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
+ -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
+ -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
+
+ procedure Apply_Float_Conversion_Check
+ (Ck_Node : 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));
+ Target_Base : constant Entity_Id := Implementation_Base_Type
+ (Target_Typ);
+ Max_Bound : constant Uint := UI_Expon
+ (Machine_Radix (Expr_Type),
+ Machine_Mantissa (Expr_Type) - 1) - 1;
+ -- Largest bound, so bound plus or minus half is a machine number of F
+
+ Ifirst,
+ Ilast : Uint; -- Bounds of integer type
+ Lo, Hi : Ureal; -- Bounds to check in floating-point domain
+ Lo_OK,
+ Hi_OK : Boolean; -- True iff Lo resp. Hi belongs to I'Range
+
+ Lo_Chk,
+ Hi_Chk : Node_Id; -- Expressions that are False iff check fails
+
+ Reason : RT_Exception_Code;
+
+ begin
+ if not Compile_Time_Known_Value (LB)
+ or not Compile_Time_Known_Value (HB)
+ then
+ declare
+ -- First check that the value falls in the range of the base
+ -- type, to prevent overflow during conversion and then
+ -- perform a regular range check against the (dynamic) bounds.
+
+ Par : constant Node_Id := Parent (Ck_Node);
+
+ pragma Assert (Target_Base /= Target_Typ);
+ pragma Assert (Nkind (Par) = N_Type_Conversion);
+
+ Temp : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ begin
+ Apply_Float_Conversion_Check (Ck_Node, Target_Base);
+ Set_Etype (Temp, Target_Base);
+
+ Insert_Action (Parent (Par),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
+ Expression => New_Copy_Tree (Par)),
+ Suppress => All_Checks);
+
+ Insert_Action (Par,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd => New_Occurrence_Of (Temp, Loc),
+ Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
+ Reason => CE_Range_Check_Failed));
+ Rewrite (Par, New_Occurrence_Of (Temp, Loc));
+
+ return;
+ end;
+ end if;
+
+ -- Get the bounds of the target type
+
+ Ifirst := Expr_Value (LB);
+ Ilast := Expr_Value (HB);
+
+ -- Check against lower bound
+
+ if abs (Ifirst) < Max_Bound then
+ Lo := UR_From_Uint (Ifirst) - Ureal_Half;
+ Lo_OK := (Ifirst > 0);
+ else
+ Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
+ Lo_OK := (Lo >= UR_From_Uint (Ifirst));
+ end if;
+
+ if Lo_OK then
+
+ -- Lo_Chk := (X >= Lo)
+
+ Lo_Chk := Make_Op_Ge (Loc,
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
+ 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),
+ Right_Opnd => Make_Real_Literal (Loc, Lo));
+ end if;
+
+ -- Check against higher bound
+
+ if abs (Ilast) < Max_Bound then
+ 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_OK := (Hi <= UR_From_Uint (Ilast));
+ end if;
+
+ if Hi_OK then
+
+ -- Hi_Chk := (X <= Hi)
+
+ Hi_Chk := Make_Op_Le (Loc,
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
+ 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),
+ Right_Opnd => Make_Real_Literal (Loc, Hi));
+ end if;
+
+ -- If the bounds of the target type are the same as those of the
+ -- base type, the check is an overflow check as a range check is
+ -- not performed in these cases.
+
+ if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
+ and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
+ then
+ Reason := CE_Overflow_Check_Failed;
+ else
+ Reason := CE_Range_Check_Failed;
+ end if;
+
+ -- Raise CE if either conditions does not hold
+
+ Insert_Action (Ck_Node,
+ Make_Raise_Constraint_Error (Loc,
+ Condition => Make_Op_Not (Loc, Make_Op_And (Loc, Lo_Chk, Hi_Chk)),
+ Reason => Reason));
+ end Apply_Float_Conversion_Check;
+
------------------------
-- Apply_Length_Check --
------------------------
-- and no floating point type is involved in the type conversion
-- then fixed point values must be read as integral values.
+ Float_To_Int : constant Boolean :=
+ Is_Floating_Point_Type (Expr_Type)
+ and then Is_Integer_Type (Target_Type);
+
begin
if not Overflow_Checks_Suppressed (Target_Base)
and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
+ and then not Float_To_Int
then
Set_Do_Overflow_Check (N);
end if;
if not Range_Checks_Suppressed (Target_Type)
and then not Range_Checks_Suppressed (Expr_Type)
then
- Apply_Scalar_Range_Check
- (Expr, Target_Type, Fixed_Int => Conv_OK);
+ if Float_To_Int then
+ Apply_Float_Conversion_Check (Expr, Target_Type);
+ else
+ Apply_Scalar_Range_Check
+ (Expr, Target_Type, Fixed_Int => Conv_OK);
+ end if;
end if;
end;
function Build_Discriminant_Checks
(N : Node_Id;
- T_Typ : Entity_Id)
- return Node_Id
+ T_Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Cond : Node_Id;
end Check_Valid_Lvalue_Subscripts;
----------------------------------
+ -- Null_Exclusion_Static_Checks --
+ ----------------------------------
+
+ procedure Null_Exclusion_Static_Checks (N : Node_Id) is
+ K : constant Node_Kind := Nkind (N);
+ Typ : Entity_Id;
+ Related_Nod : Node_Id;
+ Has_Null_Exclusion : Boolean := False;
+
+ type Msg_Kind is (Components, Formals, Objects);
+ Msg_K : Msg_Kind := Objects;
+ -- Used by local subprograms to generate precise error messages
+
+ procedure Check_Must_Be_Access
+ (Typ : Entity_Id;
+ Has_Null_Exclusion : Boolean);
+ -- ??? local subprograms must have comment on spec
+
+ procedure Check_Already_Null_Excluding_Type
+ (Typ : Entity_Id;
+ Has_Null_Exclusion : Boolean;
+ Related_Nod : Node_Id);
+ -- ??? local subprograms must have comment on spec
+
+ procedure Check_Must_Be_Initialized
+ (N : Node_Id;
+ Related_Nod : Node_Id);
+ -- ??? local subprograms must have comment on spec
+
+ procedure Check_Null_Not_Allowed (N : Node_Id);
+ -- ??? local subprograms must have comment on spec
+
+ -- ??? following bodies lack comments
+
+ --------------------------
+ -- Check_Must_Be_Access --
+ --------------------------
+
+ procedure Check_Must_Be_Access
+ (Typ : Entity_Id;
+ Has_Null_Exclusion : Boolean)
+ is
+ begin
+ if Has_Null_Exclusion
+ and then not Is_Access_Type (Typ)
+ then
+ Error_Msg_N ("(Ada 0Y) must be an access type", Related_Nod);
+ end if;
+ end Check_Must_Be_Access;
+
+ ---------------------------------------
+ -- Check_Already_Null_Excluding_Type --
+ ---------------------------------------
+
+ procedure Check_Already_Null_Excluding_Type
+ (Typ : Entity_Id;
+ Has_Null_Exclusion : Boolean;
+ Related_Nod : Node_Id)
+ is
+ begin
+ if Has_Null_Exclusion
+ and then Can_Never_Be_Null (Typ)
+ then
+ Error_Msg_N
+ ("(Ada 0Y) already a null-excluding type", Related_Nod);
+ end if;
+ end Check_Already_Null_Excluding_Type;
+
+ -------------------------------
+ -- Check_Must_Be_Initialized --
+ -------------------------------
+
+ procedure Check_Must_Be_Initialized
+ (N : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ Expr : constant Node_Id := Expression (N);
+
+ begin
+ pragma Assert (Nkind (N) = N_Component_Declaration
+ or else Nkind (N) = N_Object_Declaration);
+
+ if not Present (Expr) then
+ case Msg_K is
+ when Components =>
+ Error_Msg_N
+ ("(Ada 0Y) null-excluding components must be initialized",
+ Related_Nod);
+
+ when Formals =>
+ Error_Msg_N
+ ("(Ada 0Y) null-excluding formals must be initialized",
+ Related_Nod);
+
+ when Objects =>
+ Error_Msg_N
+ ("(Ada 0Y) null-excluding objects must be initialized",
+ Related_Nod);
+ end case;
+ end if;
+ end Check_Must_Be_Initialized;
+
+ ----------------------------
+ -- Check_Null_Not_Allowed --
+ ----------------------------
+
+ procedure Check_Null_Not_Allowed (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+
+ begin
+ if Present (Expr)
+ and then Nkind (Expr) = N_Null
+ then
+ case Msg_K is
+ when Components =>
+ Error_Msg_N
+ ("(Ada 0Y) NULL not allowed in null-excluding components",
+ Expr);
+
+ when Formals =>
+ Error_Msg_N
+ ("(Ada 0Y) NULL not allowed in null-excluding formals",
+ Expr);
+
+ when Objects =>
+ Error_Msg_N
+ ("(Ada 0Y) NULL not allowed in null-excluding objects",
+ Expr);
+ end case;
+ end if;
+ end Check_Null_Not_Allowed;
+
+ -- Start of processing for Null_Exclusion_Static_Checks
+
+ begin
+ pragma Assert (K = N_Component_Declaration
+ or else K = N_Parameter_Specification
+ or else K = N_Object_Declaration
+ or else K = N_Discriminant_Specification
+ or else K = N_Allocator);
+
+ case K is
+ when N_Component_Declaration =>
+ Msg_K := Components;
+
+ if not Present (Access_Definition (Component_Definition (N))) then
+ Has_Null_Exclusion := Null_Exclusion_Present
+ (Component_Definition (N));
+ Typ := Etype (Subtype_Indication (Component_Definition (N)));
+ Related_Nod := Subtype_Indication (Component_Definition (N));
+ Check_Must_Be_Access (Typ, Has_Null_Exclusion);
+ Check_Already_Null_Excluding_Type
+ (Typ, Has_Null_Exclusion, Related_Nod);
+ Check_Must_Be_Initialized (N, Related_Nod);
+ end if;
+
+ Check_Null_Not_Allowed (N);
+
+ when N_Parameter_Specification =>
+ Msg_K := Formals;
+ Has_Null_Exclusion := Null_Exclusion_Present (N);
+ Typ := Entity (Parameter_Type (N));
+ Related_Nod := Parameter_Type (N);
+ Check_Must_Be_Access (Typ, Has_Null_Exclusion);
+ Check_Already_Null_Excluding_Type
+ (Typ, Has_Null_Exclusion, Related_Nod);
+ Check_Null_Not_Allowed (N);
+
+ when N_Object_Declaration =>
+ Msg_K := Objects;
+ Has_Null_Exclusion := Null_Exclusion_Present (N);
+ Typ := Entity (Object_Definition (N));
+ Related_Nod := Object_Definition (N);
+ Check_Must_Be_Access (Typ, Has_Null_Exclusion);
+ Check_Already_Null_Excluding_Type
+ (Typ, Has_Null_Exclusion, Related_Nod);
+ Check_Must_Be_Initialized (N, Related_Nod);
+ Check_Null_Not_Allowed (N);
+
+ when N_Discriminant_Specification =>
+ Msg_K := Components;
+
+ if Nkind (Discriminant_Type (N)) /= N_Access_Definition then
+ Has_Null_Exclusion := Null_Exclusion_Present (N);
+ Typ := Etype (Defining_Identifier (N));
+ Related_Nod := Discriminant_Type (N);
+ Check_Must_Be_Access (Typ, Has_Null_Exclusion);
+ Check_Already_Null_Excluding_Type
+ (Typ, Has_Null_Exclusion, Related_Nod);
+ end if;
+
+ Check_Null_Not_Allowed (N);
+
+ when N_Allocator =>
+ Msg_K := Objects;
+ Has_Null_Exclusion := Null_Exclusion_Present (N);
+ Typ := Etype (Expression (N));
+
+ if Nkind (Expression (N)) = N_Qualified_Expression then
+ Related_Nod := Subtype_Mark (Expression (N));
+ else
+ Related_Nod := Expression (N);
+ end if;
+
+ Check_Must_Be_Access (Typ, Has_Null_Exclusion);
+ Check_Already_Null_Excluding_Type
+ (Typ, Has_Null_Exclusion, Related_Nod);
+ Check_Null_Not_Allowed (N);
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Null_Exclusion_Static_Checks;
+
+ ----------------------------------
-- Conditional_Statements_Begin --
----------------------------------
if Is_Access_Type (Atyp) then
Atyp := Designated_Type (Atyp);
+
+ -- If the prefix is an access to an unconstrained array,
+ -- perform check unconditionally: it depends on the bounds
+ -- of an object and we cannot currently recognize whether
+ -- the test may be redundant.
+
+ if not Is_Constrained (Atyp) then
+ Set_Do_Range_Check (N, True);
+ return;
+ end if;
end if;
Indx := First_Index (Atyp);
is
function Within_Range_Of
(Target_Type : Entity_Id;
- Check_Type : Entity_Id)
- return Boolean;
+ Check_Type : Entity_Id) return Boolean;
-- Given a requirement for checking a range against Target_Type, and
-- and a range Check_Type against which a check has already been made,
-- determines if the check against check type is sufficient to ensure
function Within_Range_Of
(Target_Type : Entity_Id;
- Check_Type : Entity_Id)
- return Boolean
+ Check_Type : Entity_Id) return Boolean
is
begin
if Target_Type = Check_Type then
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
- Ck_Node : Node_Id)
- return Node_Id
+ Ck_Node : Node_Id) return Node_Id
is
begin
if Nkind (Cond) = N_Or_Else then
Validity_Checks_On := True;
end Insert_Valid_Check;
+ ----------------------------------
+ -- Install_Null_Excluding_Check --
+ ----------------------------------
+
+ procedure Install_Null_Excluding_Check (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Etyp : constant Entity_Id := Etype (N);
+
+ begin
+ pragma Assert (Is_Access_Type (Etyp));
+
+ -- Don't need access check if: 1) we are analyzing a generic, 2) it is
+ -- known to be non-null, or 3) the check was suppressed on the type
+
+ if Inside_A_Generic
+ or else Access_Checks_Suppressed (Etyp)
+ then
+ return;
+
+ -- Otherwise install access check
+
+ else
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
+ Right_Opnd => Make_Null (Loc)),
+ Reason => CE_Access_Check_Failed));
+ end if;
+ end Install_Null_Excluding_Check;
+
--------------------------
-- Install_Static_Check --
--------------------------
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
- Warn_Node : Node_Id := Empty)
- return Check_Result
+ Warn_Node : Node_Id := Empty) return Check_Result
is
begin
return Selected_Range_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result
+ Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
S_Typ : Entity_Id;
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
+ -- Comments required ???
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
-- True for equal literals and for nodes that denote the same constant
function Length_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Typ'Length /= Exptyp'Length
function Length_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Typ'Length /= Expr'Length
function Length_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
function Length_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result
+ Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
S_Typ : Entity_Id;
function Discrete_Range_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id;
+ Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Low_Bound (Expr) < Typ'First
-- or else
function Discrete_Expr_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id;
+ Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Expr < Typ'First
-- or else
function Get_E_First_Or_Last
(E : Entity_Id;
Indx : Nat;
- Nam : Name_Id)
- return Node_Id;
+ Nam : Name_Id) return Node_Id;
-- Returns expression to compute:
-- E'First or E'Last
function Range_Equal_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
function Range_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Return expression to compute:
-- Expr'First < Typ'First or else Expr'Last > Typ'Last
function Discrete_Expr_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ Typ : Entity_Id) return Node_Id
is
begin
return
function Discrete_Range_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ Typ : Entity_Id) return Node_Id
is
LB : Node_Id := Low_Bound (Expr);
HB : Node_Id := High_Bound (Expr);
function Get_E_First_Or_Last
(E : Entity_Id;
Indx : Nat;
- Nam : Name_Id)
- return Node_Id
+ Nam : Name_Id) return Node_Id
is
N : Node_Id;
LB : Node_Id;
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
-
end Get_N_First;
----------------
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
-
end Get_N_Last;
------------------
function Range_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
function Range_Equal_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
function Range_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
projects / platform / upstream / gcc.git / blobdiff