-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 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 Nmake; use Nmake;
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;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Snames; use Snames;
+with Sprint; use Sprint;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
-- the ability to emit constraint error warning for static expressions
-- even when we are not generating code.
- ----------------------------
- -- Local Subprogram Specs --
- ----------------------------
+ -------------------------------------
+ -- Suppression of Redundant Checks --
+ -------------------------------------
+
+ -- This unit implements a limited circuit for removal of redundant
+ -- checks. The processing is based on a tracing of simple sequential
+ -- flow. For any sequence of statements, we save expressions that are
+ -- marked to be checked, and then if the same expression appears later
+ -- with the same check, then under certain circumstances, the second
+ -- check can be suppressed.
+
+ -- Basically, we can suppress the check if we know for certain that
+ -- the previous expression has been elaborated (together with its
+ -- check), and we know that the exception frame is the same, and that
+ -- nothing has happened to change the result of the exception.
+
+ -- Let us examine each of these three conditions in turn to describe
+ -- how we ensure that this condition is met.
+
+ -- First, we need to know for certain that the previous expression has
+ -- been executed. This is done principly by the mechanism of calling
+ -- Conditional_Statements_Begin at the start of any statement sequence
+ -- and Conditional_Statements_End at the end. The End call causes all
+ -- checks remembered since the Begin call to be discarded. This does
+ -- miss a few cases, notably the case of a nested BEGIN-END block with
+ -- no exception handlers. But the important thing is to be conservative.
+ -- The other protection is that all checks are discarded if a label
+ -- is encountered, since then the assumption of sequential execution
+ -- is violated, and we don't know enough about the flow.
+
+ -- Second, we need to know that the exception frame is the same. We
+ -- do this by killing all remembered checks when we enter a new frame.
+ -- Again, that's over-conservative, but generally the cases we can help
+ -- with are pretty local anyway (like the body of a loop for example).
+
+ -- Third, we must be sure to forget any checks which are no longer valid.
+ -- This is done by two mechanisms, first the Kill_Checks_Variable call is
+ -- used to note any changes to local variables. We only attempt to deal
+ -- with checks involving local variables, so we do not need to worry
+ -- about global variables. Second, a call to any non-global procedure
+ -- causes us to abandon all stored checks, since such a all may affect
+ -- the values of any local variables.
+
+ -- The following define the data structures used to deal with remembering
+ -- checks so that redundant checks can be eliminated as described above.
+
+ -- Right now, the only expressions that we deal with are of the form of
+ -- simple local objects (either declared locally, or IN parameters) or
+ -- such objects plus/minus a compile time known constant. We can do
+ -- more later on if it seems worthwhile, but this catches many simple
+ -- cases in practice.
+
+ -- The following record type reflects a single saved check. An entry
+ -- is made in the stack of saved checks if and only if the expression
+ -- has been elaborated with the indicated checks.
+
+ type Saved_Check is record
+ Killed : Boolean;
+ -- Set True if entry is killed by Kill_Checks
+
+ Entity : Entity_Id;
+ -- The entity involved in the expression that is checked
+
+ Offset : Uint;
+ -- A compile time value indicating the result of adding or
+ -- subtracting a compile time value. This value is to be
+ -- added to the value of the Entity. A value of zero is
+ -- used for the case of a simple entity reference.
+
+ Check_Type : Character;
+ -- This is set to 'R' for a range check (in which case Target_Type
+ -- is set to the target type for the range check) or to 'O' for an
+ -- overflow check (in which case Target_Type is set to Empty).
+
+ Target_Type : Entity_Id;
+ -- Used only if Do_Range_Check is set. Records the target type for
+ -- the check. We need this, because a check is a duplicate only if
+ -- it has a the same target type (or more accurately one with a
+ -- range that is smaller or equal to the stored target type of a
+ -- saved check).
+ end record;
+
+ -- The following table keeps track of saved checks. Rather than use an
+ -- extensible table. We just use a table of fixed size, and we discard
+ -- any saved checks that do not fit. That's very unlikely to happen and
+ -- this is only an optimization in any case.
+
+ Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
+ -- Array of saved checks
+
+ Num_Saved_Checks : Nat := 0;
+ -- Number of saved checks
+
+ -- The following stack keeps track of statement ranges. It is treated
+ -- as a stack. When Conditional_Statements_Begin is called, an entry
+ -- is pushed onto this stack containing the value of Num_Saved_Checks
+ -- at the time of the call. Then when Conditional_Statements_End is
+ -- called, this value is popped off and used to reset Num_Saved_Checks.
+
+ -- Note: again, this is a fixed length stack with a size that should
+ -- always be fine. If the value of the stack pointer goes above the
+ -- limit, then we just forget all saved checks.
+
+ Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
+ Saved_Checks_TOS : Nat := 0;
+
+ -----------------------
+ -- 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;
-- routine. The Do_Static flag indicates that only a static check is
-- to be done.
+ procedure Find_Check
+ (Expr : Node_Id;
+ Check_Type : Character;
+ Target_Type : Entity_Id;
+ Entry_OK : out Boolean;
+ Check_Num : out Nat;
+ Ent : out Entity_Id;
+ Ofs : out Uint);
+ -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
+ -- to see if a check is of the form for optimization, and if so, to see
+ -- if it has already been performed. Expr is the expression to check,
+ -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
+ -- Target_Type is the target type for a range check, and Empty for an
+ -- overflow check. If the entry is not of the form for optimization,
+ -- then Entry_OK is set to False, and the remaining out parameters
+ -- are undefined. If the entry is OK, then Ent/Ofs are set to the
+ -- entity and offset from the expression. Check_Num is the number of
+ -- a matching saved entry in Saved_Checks, or zero if no such entry
+ -- is located.
+
function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
-- If a discriminal is used in constraining a prival, Return reference
-- to the discriminal of the protected body (which renames the parameter
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.
function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Access_Checks
- or else (Present (E) and then Suppress_Access_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Access_Check);
+ else
+ return Scope_Suppress (Access_Check);
+ end if;
end Access_Checks_Suppressed;
-------------------------------------
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Accessibility_Checks
- or else (Present (E) and then Suppress_Accessibility_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Accessibility_Check);
+ else
+ return Scope_Suppress (Accessibility_Check);
+ end if;
end Accessibility_Checks_Suppressed;
-------------------------
Static_Sloc : Source_Ptr;
Flag_Node : Node_Id)
is
- Internal_Flag_Node : Node_Id := Flag_Node;
- Internal_Static_Sloc : Source_Ptr := Static_Sloc;
+ Internal_Flag_Node : constant Node_Id := Flag_Node;
+ Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
+
Checks_On : constant Boolean :=
(not Index_Checks_Suppressed (Suppress_Typ))
or else
Check_Unset_Reference (P);
end if;
- if Is_Entity_Name (P)
- and then Access_Checks_Suppressed (Entity (P))
- then
+ -- We do not need access checks if prefix is known to be non-null
+
+ if Known_Non_Null (P) then
return;
+ -- We do not need access checks if they are suppressed on the type
+
elsif Access_Checks_Suppressed (Etype (P)) then
return;
- else
- Set_Do_Access_Check (N, True);
+ -- We do not need checks if we are not generating code (i.e. the
+ -- expander is not active). This is not just an optimization, there
+ -- are cases (e.g. with pragma Debug) where generating the checks
+ -- can cause real trouble).
+
+ elsif not Expander_Active then
+ return;
+ end if;
+
+ -- Case where P is an entity name
+
+ if Is_Entity_Name (P) then
+ declare
+ Ent : constant Entity_Id := Entity (P);
+
+ begin
+ if Access_Checks_Suppressed (Ent) then
+ return;
+ end if;
+
+ -- Otherwise we are going to generate an access check, and
+ -- are we have done it, the entity will now be known non null
+ -- But we have to check for safe sequential semantics here!
+
+ if Safe_To_Capture_Value (N, Ent) then
+ Set_Is_Known_Non_Null (Ent);
+ end if;
+ end;
end if;
+
+ -- Access check is required
+
+ Install_Null_Excluding_Check (P);
end Apply_Access_Check;
-------------------------------
Expr : Node_Id;
Loc : Source_Ptr;
+ Alignment_Required : constant Boolean := Maximum_Alignment > 1;
+ -- Constant to show whether target requires alignment checks
+
begin
- if No (AC) or else Range_Checks_Suppressed (E) then
+ -- See if check needed. Note that we never need a check if the
+ -- maximum alignment is one, since the check will always succeed
+
+ if No (AC)
+ or else not Check_Address_Alignment (AC)
+ or else not Alignment_Required
+ then
return;
end if;
Expr := Expression (Expr);
elsif Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First (Parameter_Associations (Expr));
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 =>
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Integer_Address),
- Duplicate_Subexpr (Expr)),
+ Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc),
end if;
return;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Apply_Alignment_Check;
-------------------------------------
Ctyp : Entity_Id;
Opnd : Node_Id;
Cent : RE_Id;
- Lo : Uint;
- Hi : Uint;
- OK : Boolean;
begin
- if Backend_Overflow_Checks_On_Target
- or not Do_Overflow_Check (N)
- or not Expander_Active
- then
- return;
- end if;
-
- -- Nothing to do if the range of the result is known OK
-
- Determine_Range (N, OK, Lo, Hi);
-
- -- Note in the test below that we assume that if a bound of the
- -- range is equal to that of the type. That's not quite accurate
- -- but we do this for the following reasons:
-
- -- a) The way that Determine_Range works, it will typically report
- -- the bounds of the value are the bounds of the type, because
- -- it either can't tell anything more precise, or does not think
- -- it is worth the effort to be more precise.
-
- -- b) It is very unusual to have a situation in which this would
- -- generate an unnecessary overflow check (an example would be
- -- a subtype with a range 0 .. Integer'Last - 1 to which the
- -- literal value one is added.
-
- -- c) The alternative is a lot of special casing in this routine
- -- which would partially duplicate the Determine_Range processing.
+ -- Skip this if overflow checks are done in back end, or the overflow
+ -- flag is not set anyway, or we are not doing code expansion.
- if OK
- and then Lo > Expr_Value (Type_Low_Bound (Typ))
- and then Hi < Expr_Value (Type_High_Bound (Typ))
+ if Backend_Overflow_Checks_On_Target
+ or else not Do_Overflow_Check (N)
+ or else not Expander_Active
then
return;
end if;
- -- None of the special case optimizations worked, so there is nothing
- -- for it but to generate the full general case code:
+ -- Otherwise, we generate the full general code for front end overflow
+ -- detection, which works by doing arithmetic in a larger type:
-- x op y
-- Now build the outer conversion
Opnd := OK_Convert_To (Typ, Opnod);
-
Analyze (Opnd);
Set_Etype (Opnd, Typ);
- Set_Analyzed (Opnd, True);
- Set_Do_Overflow_Check (Opnd, True);
- Rewrite (N, Opnd);
+ -- In the discrete type case, we directly generate the range check
+ -- for the outer operand. This range check will implement the required
+ -- overflow check.
+
+ if Is_Discrete_Type (Typ) then
+ Rewrite (N, Opnd);
+ Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed);
+
+ -- For other types, we enable overflow checking on the conversion,
+ -- after setting the node as analyzed to prevent recursive attempts
+ -- to expand the conversion node.
+
+ else
+ Set_Analyzed (Opnd, True);
+ Enable_Overflow_Check (Opnd);
+ Rewrite (N, Opnd);
+ end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Apply_Arithmetic_Overflow_Check;
----------------------------
-- and perhaps this is not quite the right value, but it is good
-- enough to catch the normal cases (and the relevant ACVC tests!)
+ -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
+ -- is computed in 32 bits without an overflow check. That's a real
+ -- problem for Ada. So what we do in GNAT 3 is to approximate the
+ -- size of an array by manually multiplying the element size by the
+ -- number of elements, and comparing that against the allowed limits.
+
+ -- In GNAT 5, the size in byte is still computed in 32 bits without
+ -- an overflow check in the dynamic case, but the size in bits is
+ -- computed in 64 bits. We assume that's good enough, so we use the
+ -- size in bits for the test.
+
procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ctyp : constant Entity_Id := Component_Type (Typ);
-- Start of processing for Apply_Array_Size_Check
begin
- if not Expander_Active
- or else Storage_Checks_Suppressed (Typ)
- then
+ -- No need for a check if not expanding
+
+ if not Expander_Active then
+ return;
+ end if;
+
+ -- No need for a check if checks are suppressed
+
+ if Storage_Checks_Suppressed (Typ) then
return;
end if;
- -- It is pointless to insert this check inside an _init_proc, because
+ -- It is pointless to insert this check inside an init proc, because
-- that's too late, we have already built the object to be the right
-- size, and if it's too large, too bad!
end if;
end loop;
- -- First step is to calculate the maximum number of elements. For this
- -- calculation, we use the actual size of the subtype if it is static,
- -- and if a bound of a subtype is non-static, we go to the bound of the
- -- base type.
+ -- GCC 3 case
- Siz := Uint_1;
- Indx := First_Index (Typ);
- while Present (Indx) loop
- Xtyp := Etype (Indx);
- Lo := Type_Low_Bound (Xtyp);
- Hi := Type_High_Bound (Xtyp);
+ if Opt.GCC_Version = 3 then
- -- If any bound raises constraint error, we will never get this
- -- far, so there is no need to generate any kind of check.
+ -- No problem if size is known at compile time (even if the front
+ -- end does not know it) because the back end does do overflow
+ -- checking on the size in bytes if it is compile time known.
- if Raises_Constraint_Error (Lo)
- or else
- Raises_Constraint_Error (Hi)
- then
- Uintp.Release (Umark);
+ if Size_Known_At_Compile_Time (Typ) then
return;
end if;
+ end if;
- -- Otherwise get bounds values
+ -- Following code is temporarily deleted, since GCC 3 is returning
+ -- zero for size in bits of large dynamic arrays. ???
- if Is_Static_Expression (Lo) then
- Lob := Expr_Value (Lo);
- else
- Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
- Static := False;
- end if;
+-- -- Otherwise we check for the size in bits exceeding 2**31-1 * 8.
+-- -- This is the case in which we could end up with problems from
+-- -- an unnoticed overflow in computing the size in bytes
+--
+-- Check_Siz := (Uint_2 ** 31 - Uint_1) * Uint_8;
+--
+-- Sizx :=
+-- Make_Attribute_Reference (Loc,
+-- Prefix => New_Occurrence_Of (Typ, Loc),
+-- Attribute_Name => Name_Size);
- if Is_Static_Expression (Hi) then
- Hib := Expr_Value (Hi);
- else
- Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
- Static := False;
- end if;
+ -- GCC 2 case (for now this is for GCC 3 dynamic case as well)
- Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
- Next_Index (Indx);
- end loop;
+ begin
+ -- First step is to calculate the maximum number of elements. For
+ -- this calculation, we use the actual size of the subtype if it is
+ -- static, and if a bound of a subtype is non-static, we go to the
+ -- bound of the base type.
+
+ Siz := Uint_1;
+ Indx := First_Index (Typ);
+ while Present (Indx) loop
+ Xtyp := Etype (Indx);
+ Lo := Type_Low_Bound (Xtyp);
+ Hi := Type_High_Bound (Xtyp);
+
+ -- If any bound raises constraint error, we will never get this
+ -- far, so there is no need to generate any kind of check.
+
+ if Raises_Constraint_Error (Lo)
+ or else
+ Raises_Constraint_Error (Hi)
+ then
+ Uintp.Release (Umark);
+ return;
+ end if;
- -- Compute the limit against which we want to check. For subprograms,
- -- where the array will go on the stack, we use 8*2**24, which (in
- -- bits) is the size of a 16 megabyte array.
+ -- Otherwise get bounds values
- if Is_Subprogram (Scope (Ent)) then
- Check_Siz := Uint_2 ** 27;
- else
- Check_Siz := Uint_2 ** 31;
- end if;
+ if Is_Static_Expression (Lo) then
+ Lob := Expr_Value (Lo);
+ else
+ Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
+ Static := False;
+ end if;
- -- If we have all static bounds and Siz is too large, then we know we
- -- know we have a storage error right now, so generate message
+ if Is_Static_Expression (Hi) then
+ Hib := Expr_Value (Hi);
+ else
+ Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
+ Static := False;
+ end if;
- if Static and then Siz >= Check_Siz then
- Insert_Action (N,
- Make_Raise_Storage_Error (Loc,
- Reason => SE_Object_Too_Large));
- Warn_On_Instance := True;
- Error_Msg_N ("?Storage_Error will be raised at run-time", N);
- Warn_On_Instance := False;
- Uintp.Release (Umark);
- return;
- end if;
+ Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
+ Next_Index (Indx);
+ end loop;
- -- Case of component size known at compile time. If the array
- -- size is definitely in range, then we do not need a check.
+ -- Compute the limit against which we want to check. For subprograms,
+ -- where the array will go on the stack, we use 8*2**24, which (in
+ -- bits) is the size of a 16 megabyte array.
- if Known_Esize (Ctyp)
- and then Siz * Esize (Ctyp) < Check_Siz
- then
- Uintp.Release (Umark);
- return;
- end if;
+ if Is_Subprogram (Scope (Ent)) then
+ Check_Siz := Uint_2 ** 27;
+ else
+ Check_Siz := Uint_2 ** 31;
+ end if;
- -- Here if a dynamic check is required
+ -- If we have all static bounds and Siz is too large, then we know
+ -- we know we have a storage error right now, so generate message
- -- What we do is to build an expression for the size of the array,
- -- which is computed as the 'Size of the array component, times
- -- the size of each dimension.
+ if Static and then Siz >= Check_Siz then
+ Insert_Action (N,
+ Make_Raise_Storage_Error (Loc,
+ Reason => SE_Object_Too_Large));
+ Error_Msg_N ("?Storage_Error will be raised at run-time", N);
+ Uintp.Release (Umark);
+ return;
+ end if;
- Uintp.Release (Umark);
+ -- Case of component size known at compile time. If the array
+ -- size is definitely in range, then we do not need a check.
- Sizx :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ctyp, Loc),
- Attribute_Name => Name_Size);
+ if Known_Esize (Ctyp)
+ and then Siz * Esize (Ctyp) < Check_Siz
+ then
+ Uintp.Release (Umark);
+ return;
+ end if;
- Indx := First_Index (Typ);
+ -- Here if a dynamic check is required
- for J in 1 .. Number_Dimensions (Typ) loop
+ -- What we do is to build an expression for the size of the array,
+ -- which is computed as the 'Size of the array component, times
+ -- the size of each dimension.
- if Sloc (Etype (Indx)) = Sloc (N) then
- Ensure_Defined (Etype (Indx), N);
- end if;
+ Uintp.Release (Umark);
Sizx :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Sizx,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Length,
- Expressions => New_List (
- Make_Integer_Literal (Loc, J))));
- Next_Index (Indx);
- end loop;
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ctyp, Loc),
+ Attribute_Name => Name_Size);
+
+ Indx := First_Index (Typ);
+ for J in 1 .. Number_Dimensions (Typ) loop
+ if Sloc (Etype (Indx)) = Sloc (N) then
+ Ensure_Defined (Etype (Indx), N);
+ end if;
+
+ Sizx :=
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Sizx,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Length,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, J))));
+ Next_Index (Indx);
+ end loop;
+ end;
+
+ -- Common code to actually emit the check
Code :=
Make_Raise_Storage_Error (Loc,
Make_Op_Ge (Loc,
Left_Opnd => Sizx,
Right_Opnd =>
- Make_Integer_Literal (Loc, Check_Siz)),
- Reason => SE_Object_Too_Large);
+ Make_Integer_Literal (Loc,
+ Intval => Check_Siz)),
+ Reason => SE_Object_Too_Large);
Set_Size_Check_Code (Defining_Identifier (N), Code);
- Insert_Action (N, Code);
+ Insert_Action (N, Code, Suppress => All_Checks);
end Apply_Array_Size_Check;
----------------------------
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;
return;
end if;
+ -- Nothing to do if the type is an Unchecked_Union
+
+ if Is_Unchecked_Union (Base_Type (T_Typ)) then
+ return;
+ end if;
+
-- Suppress checks if the subtypes are the same.
-- the check must be preserved in an assignment to a formal, because
-- the constraint is given by the actual.
if Nkind (Original_Node (N)) /= N_Allocator
and then (No (Lhs)
or else not Is_Entity_Name (Lhs)
- or else (Ekind (Entity (Lhs)) /= E_In_Out_Parameter
- and then Ekind (Entity (Lhs)) /= E_Out_Parameter))
+ or else No (Param_Entity (Lhs)))
then
if (Etype (N) = Typ
or else (Do_Access and then Designated_Type (Typ) = S_Typ))
and then Is_Entity_Name (Expression (Original_Node (N)))
then
declare
- Alloc_Typ : Entity_Id := Entity (Expression (Original_Node (N)));
+ Alloc_Typ : constant Entity_Id :=
+ Entity (Expression (Original_Node (N)));
begin
if Alloc_Typ = T_Typ
-- all the constraints are constants. In this case, we can do the
-- check successfully at compile time.
- -- we skip this check for the case where the node is a rewritten`
+ -- We skip this check for the case where the node is a rewritten`
-- allocator, because it already carries the context subtype, and
-- extracting the discriminants from the aggregate is messy.
if No (DconS) then
return;
end if;
+
+ -- A further optimization: if T_Typ is derived from S_Typ
+ -- without imposing a constraint, no check is needed.
+
+ if Nkind (Original_Node (Parent (T_Typ))) =
+ N_Full_Type_Declaration
+ then
+ declare
+ Type_Def : constant Node_Id :=
+ Type_Definition
+ (Original_Node (Parent (T_Typ)));
+ begin
+ if Nkind (Type_Def) = N_Derived_Type_Definition
+ and then Is_Entity_Name (Subtype_Indication (Type_Def))
+ and then Entity (Subtype_Indication (Type_Def)) = S_Typ
+ then
+ return;
+ end if;
+ end;
+ end if;
end if;
DconT := First_Elmt (Discriminant_Constraint (T_Typ));
Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => CE_Discriminant_Check_Failed));
-
end Apply_Discriminant_Check;
------------------------
-- part of the test is not controlled by the -gnato switch.
if Do_Division_Check (N) then
-
if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Right),
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Reason => CE_Divide_By_Zero));
end if;
Make_And_Then (Loc,
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Left),
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Left),
Right_Opnd => Make_Integer_Literal (Loc, LLB)),
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Right),
+ Left_Opnd =>
+ Duplicate_Subexpr (Right),
Right_Opnd =>
Make_Integer_Literal (Loc, -1))),
Reason => CE_Overflow_Check_Failed));
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 --
------------------------
procedure Bad_Value;
-- Procedure called if value is determined to be out of range
+ ---------------
+ -- Bad_Value --
+ ---------------
+
procedure Bad_Value is
begin
Apply_Compile_Time_Constraint_Error
Typ => Target_Typ);
end Bad_Value;
+ -- Start of processing for Apply_Scalar_Range_Check
+
begin
if Inside_A_Generic then
return;
-- Check array type and its base type
if Index_Checks_Suppressed (Arr_Typ)
- or else Suppress_Index_Checks (Base_Type (Arr_Typ))
+ or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
then
return;
-- Check array itself if it is an entity name
elsif Is_Entity_Name (Arr)
- and then Suppress_Index_Checks (Entity (Arr))
+ and then Index_Checks_Suppressed (Entity (Arr))
then
return;
-- Check expression itself if it is an entity name
elsif Is_Entity_Name (Expr)
- and then Suppress_Index_Checks (Entity (Expr))
+ and then Index_Checks_Suppressed (Entity (Expr))
then
return;
end if;
-- Check target type and its base type
if Range_Checks_Suppressed (Target_Typ)
- or else Suppress_Range_Checks (Base_Type (Target_Typ))
+ or else Range_Checks_Suppressed (Base_Type (Target_Typ))
then
return;
-- Check expression itself if it is an entity name
elsif Is_Entity_Name (Expr)
- and then Suppress_Range_Checks (Entity (Expr))
+ and then Range_Checks_Suppressed (Entity (Expr))
then
return;
elsif Nkind (Parnt) = N_Assignment_Statement
and then Is_Entity_Name (Name (Parnt))
- and then Suppress_Range_Checks (Entity (Name (Parnt)))
+ and then Range_Checks_Suppressed (Entity (Name (Parnt)))
then
return;
end if;
end if;
end if;
+ -- Do not set range checks if they are killed
+
+ if Nkind (Expr) = N_Unchecked_Type_Conversion
+ and then Kill_Range_Check (Expr)
+ then
+ return;
+ end if;
+
+ -- Do not set range checks for any values from System.Scalar_Values
+ -- since the whole idea of such values is to avoid checking them!
+
+ if Is_Entity_Name (Expr)
+ and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
+ then
+ return;
+ end if;
+
-- Now see if we need a check
if No (Source_Typ) then
Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
-- Always do a range check if the source type includes infinities
- -- and the target type does not include infinities.
+ -- and the target type does not include infinities. We do not do
+ -- this if range checks are killed.
if Is_Floating_Point_Type (S_Typ)
and then Has_Infinities (S_Typ)
if Compile_Time_Known_Value (Tlo)
and then Compile_Time_Known_Value (Thi)
then
- Determine_Range (Expr, OK, Lo, Hi);
+ declare
+ Lov : constant Uint := Expr_Value (Tlo);
+ Hiv : constant Uint := Expr_Value (Thi);
- if OK then
- declare
- Lov : constant Uint := Expr_Value (Tlo);
- Hiv : constant Uint := Expr_Value (Thi);
+ begin
+ -- If range is null, we for sure have a constraint error
+ -- (we don't even need to look at the value involved,
+ -- since all possible values will raise CE).
+
+ if Lov > Hiv then
+ Bad_Value;
+ return;
+ end if;
+
+ -- Otherwise determine range of value
+
+ Determine_Range (Expr, OK, Lo, Hi);
+
+ if OK then
+
+ -- If definitely in range, all OK
- begin
if Lo >= Lov and then Hi <= Hiv then
return;
+ -- If definitely not in range, warn
+
elsif Lov > Hi or else Hiv < Lo then
Bad_Value;
return;
+
+ -- Otherwise we don't know
+
+ else
+ null;
end if;
- end;
- end if;
+ end if;
+ end;
end if;
end;
end if;
or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
-- Check if we can determine at compile time whether Expr is in the
- -- range of the target type. Note that if S_Typ is within the
- -- bounds of Target_Typ then this must be the case. This checks is
- -- only meaningful if this is not a conversion between integer and
- -- real types.
+ -- range of the target type. Note that if S_Typ is within the bounds
+ -- of Target_Typ then this must be the case. This check is meaningful
+ -- only if this is not a conversion between integer and real types.
if not Is_Unconstrained_Subscr_Ref
and then
Bad_Value;
return;
- -- Do not set range checks if they are killed
+ -- In the floating-point case, we only do range checks if the
+ -- type is constrained. We definitely do NOT want range checks
+ -- for unconstrained types, since we want to have infinities
- elsif Nkind (Expr) = N_Unchecked_Type_Conversion
- and then Kill_Range_Check (Expr)
- then
- return;
+ elsif Is_Floating_Point_Type (S_Typ) then
+ if Is_Constrained (S_Typ) then
+ Enable_Range_Check (Expr);
+ end if;
- -- ??? We only need a runtime check if the target type is constrained
- -- (the predefined type Float is not for instance).
- -- so the following should really be
- --
- -- elsif Is_Constrained (Target_Typ) then
- --
- -- but it isn't because certain types do not have the Is_Constrained
- -- flag properly set (see 1503-003).
+ -- For all other cases we enable a range check unconditionally
else
Enable_Range_Check (Expr);
return;
end if;
-
end Apply_Scalar_Range_Check;
----------------------------------
Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
for J in 1 .. 2 loop
-
R_Cno := R_Result (J);
exit when No (R_Cno);
else
Install_Static_Check (R_Cno, Loc);
end if;
-
end loop;
-
end Apply_Selected_Range_Checks;
-------------------------------
procedure Apply_Type_Conversion_Checks (N : Node_Id) is
Target_Type : constant Entity_Id := Etype (N);
Target_Base : constant Entity_Id := Base_Type (Target_Type);
-
- Expr : constant Node_Id := Expression (N);
- Expr_Type : constant Entity_Id := Etype (Expr);
+ Expr : constant Node_Id := Expression (N);
+ Expr_Type : constant Entity_Id := Etype (Expr);
begin
if Inside_A_Generic then
return;
-- Scalar type conversions of the form Target_Type (Expr) require
- -- two checks:
- --
- -- - First there is an overflow check to insure that Expr is
- -- in the base type of Target_Typ (4.6 (28)),
- --
- -- - After we know Expr fits into the base type, we must perform a
- -- range check to ensure that Expr meets the constraints of the
- -- Target_Type.
+ -- a range check if we cannot be sure that Expr is in the base type
+ -- of Target_Typ and also that Expr is in the range of Target_Typ.
+ -- These are not quite the same condition from an implementation
+ -- point of view, but clearly the second includes the first.
elsif Is_Scalar_Type (Target_Type) then
declare
-- and no floating point type is involved in the type conversion
-- then fixed point values must be read as integral values.
- begin
- -- Overflow check.
+ 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;
and then Is_Derived_Type (Target_Type)
and then not Is_Tagged_Type (Target_Type)
and then not Is_Constrained (Target_Type)
- and then Present (Girder_Constraint (Target_Type))
+ and then Present (Stored_Constraint (Target_Type))
then
- -- A unconstrained derived type may have inherited discriminants.
- -- Build an actual discriminant constraint list using the girder
+ -- An unconstrained derived type may have inherited discriminant
+ -- Build an actual discriminant constraint list using the stored
-- constraint, to verify that the expression of the parent type
-- satisfies the constraints imposed by the (unconstrained!)
-- derived type. This applies to value conversions, not to view
-- conversions of tagged types.
declare
- Loc : constant Source_Ptr := Sloc (N);
- Cond : Node_Id;
- Constraint : Elmt_Id;
- Discr_Value : Node_Id;
- Discr : Entity_Id;
- New_Constraints : Elist_Id := New_Elmt_List;
- Old_Constraints : Elist_Id := Discriminant_Constraint (Expr_Type);
+ Loc : constant Source_Ptr := Sloc (N);
+ Cond : Node_Id;
+ Constraint : Elmt_Id;
+ Discr_Value : Node_Id;
+ Discr : Entity_Id;
+
+ New_Constraints : constant Elist_Id := New_Elmt_List;
+ Old_Constraints : constant Elist_Id :=
+ Discriminant_Constraint (Expr_Type);
begin
- Constraint := First_Elmt (Girder_Constraint (Target_Type));
+ Constraint := First_Elmt (Stored_Constraint (Target_Type));
while Present (Constraint) loop
Discr_Value := Node (Constraint);
-- Parent is constrained by new discriminant. Obtain
-- Value of original discriminant in expression. If
-- the new discriminant has been used to constrain more
- -- than one of the girder ones, this will provide the
- -- required consistency check.
+ -- than one of the stored discriminants, this will
+ -- provide the required consistency check.
Append_Elmt (
Make_Selected_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Expr, Name_Req => True),
+ Duplicate_Subexpr_No_Checks
+ (Expr, Name_Req => True),
Selector_Name =>
Make_Identifier (Loc, Chars (Discr))),
New_Constraints);
end if;
-- Derived type definition has an explicit value for
- -- this girder discriminant.
+ -- this stored discriminant.
else
Append_Elmt
- (Duplicate_Subexpr (Discr_Value), New_Constraints);
+ (Duplicate_Subexpr_No_Checks (Discr_Value),
+ New_Constraints);
end if;
Next_Elmt (Constraint);
Reason => CE_Discriminant_Check_Failed));
end;
- -- should there be other checks here for array types ???
+ -- For arrays, conversions are applied during expansion, to take
+ -- into accounts changes of representation. The checks become range
+ -- checks on the base type or length checks on the subtype, depending
+ -- on whether the target type is unconstrained or constrained.
else
null;
end if;
-
end Apply_Type_Conversion_Checks;
----------------------------------------------
elsif not Comes_From_Source (N) then
return;
+ -- If the prefix is a selected component that depends on a discriminant
+ -- the check may improperly expose a discriminant instead of using
+ -- the bounds of the object itself. Set the type of the attribute to
+ -- the base type of the context, so that a check will be imposed when
+ -- needed (e.g. if the node appears as an index).
+
+ elsif Nkind (Prefix (N)) = N_Selected_Component
+ and then Ekind (Typ) = E_Signed_Integer_Subtype
+ and then Depends_On_Discriminant (Scalar_Range (Typ))
+ then
+ Set_Etype (N, Base_Type (Typ));
+
-- Otherwise, replace the attribute node with a type conversion
-- node whose expression is the attribute, retyped to universal
-- integer, and whose subtype mark is the target type. The call
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;
Disc : Elmt_Id;
Disc_Ent : Entity_Id;
+ Dref : Node_Id;
Dval : Node_Id;
begin
Cond := Empty;
Disc := First_Elmt (Discriminant_Constraint (T_Typ));
- -- For a fully private type, use the discriminants of the parent
- -- type.
+ -- For a fully private type, use the discriminants of the parent type
if Is_Private_Type (T_Typ)
and then No (Full_View (T_Typ))
end if;
while Present (Disc) loop
-
Dval := Node (Disc);
if Nkind (Dval) = N_Identifier
then
Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
else
- Dval := Duplicate_Subexpr (Dval);
+ Dval := Duplicate_Subexpr_No_Checks (Dval);
+ end if;
+
+ -- If we have an Unchecked_Union node, we can infer the discriminants
+ -- of the node.
+
+ if Is_Unchecked_Union (Base_Type (T_Typ)) then
+ Dref := New_Copy (
+ Get_Discriminant_Value (
+ First_Discriminant (T_Typ),
+ T_Typ,
+ Stored_Constraint (T_Typ)));
+
+ else
+ Dref :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Disc_Ent)));
+
+ Set_Is_In_Discriminant_Check (Dref);
end if;
Evolve_Or_Else (Cond,
Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Disc_Ent))),
+ Left_Opnd => Dref,
Right_Opnd => Dval));
Next_Elmt (Disc);
end if;
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 2005) 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 2005) 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 2005) null-excluding components must be " &
+ "initialized", Related_Nod);
+
+ when Formals =>
+ Error_Msg_N
+ ("(Ada 2005) null-excluding formals must be initialized",
+ Related_Nod);
+
+ when Objects =>
+ Error_Msg_N
+ ("(Ada 2005) 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 2005) NULL not allowed in null-excluding " &
+ "components", Expr);
+
+ when Formals =>
+ Error_Msg_N
+ ("(Ada 2005) NULL not allowed in null-excluding formals",
+ Expr);
+
+ when Objects =>
+ Error_Msg_N
+ ("(Ada 2005) 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 --
+ ----------------------------------
+
+ procedure Conditional_Statements_Begin is
+ begin
+ Saved_Checks_TOS := Saved_Checks_TOS + 1;
+
+ -- If stack overflows, kill all checks, that way we know to
+ -- simply reset the number of saved checks to zero on return.
+ -- This should never occur in practice.
+
+ if Saved_Checks_TOS > Saved_Checks_Stack'Last then
+ Kill_All_Checks;
+
+ -- In the normal case, we just make a new stack entry saving
+ -- the current number of saved checks for a later restore.
+
+ else
+ Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
+
+ if Debug_Flag_CC then
+ w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
+ Num_Saved_Checks);
+ end if;
+ end if;
+ end Conditional_Statements_Begin;
+
+ --------------------------------
+ -- Conditional_Statements_End --
+ --------------------------------
+
+ procedure Conditional_Statements_End is
+ begin
+ pragma Assert (Saved_Checks_TOS > 0);
+
+ -- If the saved checks stack overflowed, then we killed all
+ -- checks, so setting the number of saved checks back to
+ -- zero is correct. This should never occur in practice.
+
+ if Saved_Checks_TOS > Saved_Checks_Stack'Last then
+ Num_Saved_Checks := 0;
+
+ -- In the normal case, restore the number of saved checks
+ -- from the top stack entry.
+
+ else
+ Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
+ if Debug_Flag_CC then
+ w ("Conditional_Statements_End: Num_Saved_Checks = ",
+ Num_Saved_Checks);
+ end if;
+ end if;
+
+ Saved_Checks_TOS := Saved_Checks_TOS - 1;
+ end Conditional_Statements_End;
+
---------------------
-- Determine_Range --
---------------------
when N_Op_Mod =>
if OK_Operands then
- if Lo_Right = Hi_Right then
+ if Lo_Right = Hi_Right
+ and then Lo_Right /= 0
+ then
if Lo_Right > 0 then
Lor := Uint_0;
Hir := Lo_Right - 1;
- elsif Lo_Right < 0 then
+ else -- Lo_Right < 0
Lor := Lo_Right + 1;
Hir := Uint_0;
end if;
when N_Op_Rem =>
if OK_Operands then
- if Lo_Right = Hi_Right then
+ if Lo_Right = Hi_Right
+ and then Lo_Right /= 0
+ then
declare
Dval : constant Uint := (abs Lo_Right) - 1;
Hi := No_Uint;
return;
end if;
-
end Determine_Range;
------------------------------------
function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Discriminant_Checks
- or else (Present (E) and then Suppress_Discriminant_Checks (E));
+ if Present (E) then
+ if Is_Unchecked_Union (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Discriminant_Check);
+ end if;
+ end if;
+
+ return Scope_Suppress (Discriminant_Check);
end Discriminant_Checks_Suppressed;
--------------------------------
function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Division_Checks
- or else (Present (E) and then Suppress_Division_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Division_Check);
+ else
+ return Scope_Suppress (Division_Check);
+ end if;
end Division_Checks_Suppressed;
-----------------------------------
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Elaboration_Checks
- or else (Present (E) and then Suppress_Elaboration_Checks (E));
+ if Present (E) then
+ if Kill_Elaboration_Checks (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Elaboration_Check);
+ end if;
+ end if;
+
+ return Scope_Suppress (Elaboration_Check);
end Elaboration_Checks_Suppressed;
+ ---------------------------
+ -- Enable_Overflow_Check --
+ ---------------------------
+
+ procedure Enable_Overflow_Check (N : Node_Id) is
+ Typ : constant Entity_Id := Base_Type (Etype (N));
+ Chk : Nat;
+ OK : Boolean;
+ Ent : Entity_Id;
+ Ofs : Uint;
+ Lo : Uint;
+ Hi : Uint;
+
+ begin
+ if Debug_Flag_CC then
+ w ("Enable_Overflow_Check for node ", Int (N));
+ Write_Str (" Source location = ");
+ wl (Sloc (N));
+ pg (N);
+ end if;
+
+ -- Nothing to do if the range of the result is known OK. We skip
+ -- this for conversions, since the caller already did the check,
+ -- and in any case the condition for deleting the check for a
+ -- type conversion is different in any case.
+
+ if Nkind (N) /= N_Type_Conversion then
+ Determine_Range (N, OK, Lo, Hi);
+
+ -- Note in the test below that we assume that if a bound of the
+ -- range is equal to that of the type. That's not quite accurate
+ -- but we do this for the following reasons:
+
+ -- a) The way that Determine_Range works, it will typically report
+ -- the bounds of the value as being equal to the bounds of the
+ -- type, because it either can't tell anything more precise, or
+ -- does not think it is worth the effort to be more precise.
+
+ -- b) It is very unusual to have a situation in which this would
+ -- generate an unnecessary overflow check (an example would be
+ -- a subtype with a range 0 .. Integer'Last - 1 to which the
+ -- literal value one is added.
+
+ -- c) The alternative is a lot of special casing in this routine
+ -- which would partially duplicate Determine_Range processing.
+
+ if OK
+ and then Lo > Expr_Value (Type_Low_Bound (Typ))
+ and then Hi < Expr_Value (Type_High_Bound (Typ))
+ then
+ if Debug_Flag_CC then
+ w ("No overflow check required");
+ end if;
+
+ return;
+ end if;
+ end if;
+
+ -- If not in optimizing mode, set flag and we are done. We are also
+ -- done (and just set the flag) if the type is not a discrete type,
+ -- since it is not worth the effort to eliminate checks for other
+ -- than discrete types. In addition, we take this same path if we
+ -- have stored the maximum number of checks possible already (a
+ -- very unlikely situation, but we do not want to blow up!)
+
+ if Optimization_Level = 0
+ or else not Is_Discrete_Type (Etype (N))
+ or else Num_Saved_Checks = Saved_Checks'Last
+ then
+ Set_Do_Overflow_Check (N, True);
+
+ if Debug_Flag_CC then
+ w ("Optimization off");
+ end if;
+
+ return;
+ end if;
+
+ -- Otherwise evaluate and check the expression
+
+ Find_Check
+ (Expr => N,
+ Check_Type => 'O',
+ Target_Type => Empty,
+ Entry_OK => OK,
+ Check_Num => Chk,
+ Ent => Ent,
+ Ofs => Ofs);
+
+ if Debug_Flag_CC then
+ w ("Called Find_Check");
+ w (" OK = ", OK);
+
+ if OK then
+ w (" Check_Num = ", Chk);
+ w (" Ent = ", Int (Ent));
+ Write_Str (" Ofs = ");
+ pid (Ofs);
+ end if;
+ end if;
+
+ -- If check is not of form to optimize, then set flag and we are done
+
+ if not OK then
+ Set_Do_Overflow_Check (N, True);
+ return;
+ end if;
+
+ -- If check is already performed, then return without setting flag
+
+ if Chk /= 0 then
+ if Debug_Flag_CC then
+ w ("Check suppressed!");
+ end if;
+
+ return;
+ end if;
+
+ -- Here we will make a new entry for the new check
+
+ Set_Do_Overflow_Check (N, True);
+ Num_Saved_Checks := Num_Saved_Checks + 1;
+ Saved_Checks (Num_Saved_Checks) :=
+ (Killed => False,
+ Entity => Ent,
+ Offset => Ofs,
+ Check_Type => 'O',
+ Target_Type => Empty);
+
+ if Debug_Flag_CC then
+ w ("Make new entry, check number = ", Num_Saved_Checks);
+ w (" Entity = ", Int (Ent));
+ Write_Str (" Offset = ");
+ pid (Ofs);
+ w (" Check_Type = O");
+ w (" Target_Type = Empty");
+ end if;
+
+ -- If we get an exception, then something went wrong, probably because
+ -- of an error in the structure of the tree due to an incorrect program.
+ -- Or it may be a bug in the optimization circuit. In either case the
+ -- safest thing is simply to set the check flag unconditionally.
+
+ exception
+ when others =>
+ Set_Do_Overflow_Check (N, True);
+
+ if Debug_Flag_CC then
+ w (" exception occurred, overflow flag set");
+ end if;
+
+ return;
+ end Enable_Overflow_Check;
+
------------------------
-- Enable_Range_Check --
------------------------
procedure Enable_Range_Check (N : Node_Id) is
+ Chk : Nat;
+ OK : Boolean;
+ Ent : Entity_Id;
+ Ofs : Uint;
+ Ttyp : Entity_Id;
+ P : Node_Id;
+
begin
+ -- Return if unchecked type conversion with range check killed.
+ -- In this case we never set the flag (that's what Kill_Range_Check
+ -- is all about!)
+
if Nkind (N) = N_Unchecked_Type_Conversion
and then Kill_Range_Check (N)
then
return;
+ end if;
+
+ -- Debug trace output
+
+ if Debug_Flag_CC then
+ w ("Enable_Range_Check for node ", Int (N));
+ Write_Str (" Source location = ");
+ wl (Sloc (N));
+ pg (N);
+ end if;
+
+ -- If not in optimizing mode, set flag and we are done. We are also
+ -- done (and just set the flag) if the type is not a discrete type,
+ -- since it is not worth the effort to eliminate checks for other
+ -- than discrete types. In addition, we take this same path if we
+ -- have stored the maximum number of checks possible already (a
+ -- very unlikely situation, but we do not want to blow up!)
+
+ if Optimization_Level = 0
+ or else No (Etype (N))
+ or else not Is_Discrete_Type (Etype (N))
+ or else Num_Saved_Checks = Saved_Checks'Last
+ then
+ Set_Do_Range_Check (N, True);
+
+ if Debug_Flag_CC then
+ w ("Optimization off");
+ end if;
+
+ return;
+ end if;
+
+ -- Otherwise find out the target type
+
+ P := Parent (N);
+
+ -- For assignment, use left side subtype
+
+ if Nkind (P) = N_Assignment_Statement
+ and then Expression (P) = N
+ then
+ Ttyp := Etype (Name (P));
+
+ -- For indexed component, use subscript subtype
+
+ elsif Nkind (P) = N_Indexed_Component then
+ declare
+ Atyp : Entity_Id;
+ Indx : Node_Id;
+ Subs : Node_Id;
+
+ begin
+ Atyp := Etype (Prefix (P));
+
+ 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);
+ Subs := First (Expressions (P));
+ loop
+ if Subs = N then
+ Ttyp := Etype (Indx);
+ exit;
+ end if;
+
+ Next_Index (Indx);
+ Next (Subs);
+ end loop;
+ end;
+
+ -- For now, ignore all other cases, they are not so interesting
+
else
+ if Debug_Flag_CC then
+ w (" target type not found, flag set");
+ end if;
+
+ Set_Do_Range_Check (N, True);
+ return;
+ end if;
+
+ -- Evaluate and check the expression
+
+ Find_Check
+ (Expr => N,
+ Check_Type => 'R',
+ Target_Type => Ttyp,
+ Entry_OK => OK,
+ Check_Num => Chk,
+ Ent => Ent,
+ Ofs => Ofs);
+
+ if Debug_Flag_CC then
+ w ("Called Find_Check");
+ w ("Target_Typ = ", Int (Ttyp));
+ w (" OK = ", OK);
+
+ if OK then
+ w (" Check_Num = ", Chk);
+ w (" Ent = ", Int (Ent));
+ Write_Str (" Ofs = ");
+ pid (Ofs);
+ end if;
+ end if;
+
+ -- If check is not of form to optimize, then set flag and we are done
+
+ if not OK then
+ if Debug_Flag_CC then
+ w (" expression not of optimizable type, flag set");
+ end if;
+
Set_Do_Range_Check (N, True);
+ return;
+ end if;
+
+ -- If check is already performed, then return without setting flag
+
+ if Chk /= 0 then
+ if Debug_Flag_CC then
+ w ("Check suppressed!");
+ end if;
+
+ return;
+ end if;
+
+ -- Here we will make a new entry for the new check
+
+ Set_Do_Range_Check (N, True);
+ Num_Saved_Checks := Num_Saved_Checks + 1;
+ Saved_Checks (Num_Saved_Checks) :=
+ (Killed => False,
+ Entity => Ent,
+ Offset => Ofs,
+ Check_Type => 'R',
+ Target_Type => Ttyp);
+
+ if Debug_Flag_CC then
+ w ("Make new entry, check number = ", Num_Saved_Checks);
+ w (" Entity = ", Int (Ent));
+ Write_Str (" Offset = ");
+ pid (Ofs);
+ w (" Check_Type = R");
+ w (" Target_Type = ", Int (Ttyp));
+ pg (Ttyp);
end if;
+
+ -- If we get an exception, then something went wrong, probably because
+ -- of an error in the structure of the tree due to an incorrect program.
+ -- Or it may be a bug in the optimization circuit. In either case the
+ -- safest thing is simply to set the check flag unconditionally.
+
+ exception
+ when others =>
+ Set_Do_Range_Check (N, True);
+
+ if Debug_Flag_CC then
+ w (" exception occurred, range flag set");
+ end if;
+
+ return;
end Enable_Range_Check;
------------------
if not Validity_Checks_On then
return;
+ -- Ignore call if range checks suppressed on entity in question
+
+ elsif Is_Entity_Name (Expr)
+ and then Range_Checks_Suppressed (Entity (Expr))
+ then
+ return;
+
-- No check required if expression is from the expander, we assume
-- the expander will generate whatever checks are needed. Note that
-- this is not just an optimization, it avoids infinite recursions!
-- Unchecked conversions must be checked, unless they are initialized
- -- scalar values, as in a component assignment in an init_proc.
+ -- scalar values, as in a component assignment in an init proc.
+
+ -- In addition, we force a check if Force_Validity_Checks is set
elsif not Comes_From_Source (Expr)
+ and then not Force_Validity_Checks
and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
or else Kill_Range_Check (Expr))
then
then
return;
- -- No check required on the left-hand side of an assignment.
+ -- No check required on the left-hand side of an assignment.
+
+ elsif Nkind (Parent (Expr)) = N_Assignment_Statement
+ and then Expr = Name (Parent (Expr))
+ then
+ return;
+
+ -- An annoying special case. If this is an out parameter of a scalar
+ -- type, then the value is not going to be accessed, therefore it is
+ -- inappropriate to do any validity check at the call site.
+
+ else
+ -- Only need to worry about scalar types
+
+ if Is_Scalar_Type (Typ) then
+ declare
+ P : Node_Id;
+ N : Node_Id;
+ E : Entity_Id;
+ F : Entity_Id;
+ A : Node_Id;
+ L : List_Id;
+
+ begin
+ -- Find actual argument (which may be a parameter association)
+ -- and the parent of the actual argument (the call statement)
+
+ N := Expr;
+ P := Parent (Expr);
+
+ if Nkind (P) = N_Parameter_Association then
+ N := P;
+ P := Parent (N);
+ end if;
+
+ -- Only need to worry if we are argument of a procedure
+ -- call since functions don't have out parameters. If this
+ -- is an indirect or dispatching call, get signature from
+ -- the subprogram type.
+
+ if Nkind (P) = N_Procedure_Call_Statement then
+ L := Parameter_Associations (P);
+
+ if Is_Entity_Name (Name (P)) then
+ E := Entity (Name (P));
+ else
+ pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
+ E := Etype (Name (P));
+ end if;
+
+ -- Only need to worry if there are indeed actuals, and
+ -- if this could be a procedure call, otherwise we cannot
+ -- get a match (either we are not an argument, or the
+ -- mode of the formal is not OUT). This test also filters
+ -- out the generic case.
+
+ if Is_Non_Empty_List (L)
+ and then Is_Subprogram (E)
+ then
+ -- This is the loop through parameters, looking to
+ -- see if there is an OUT parameter for which we are
+ -- the argument.
+
+ F := First_Formal (E);
+ A := First (L);
+
+ while Present (F) loop
+ if Ekind (F) = E_Out_Parameter and then A = N then
+ return;
+ end if;
+
+ Next_Formal (F);
+ Next (A);
+ end loop;
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- If we fall through, a validity check is required. Note that it would
+ -- not be good to set Do_Range_Check, even in contexts where this is
+ -- permissible, since this flag causes checking against the target type,
+ -- not the source type in contexts such as assignments
+
+ Insert_Valid_Check (Expr);
+ end Ensure_Valid;
+
+ ----------------------
+ -- Expr_Known_Valid --
+ ----------------------
+
+ function Expr_Known_Valid (Expr : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (Expr);
+
+ begin
+ -- Non-scalar types are always consdered valid, since they never
+ -- give rise to the issues of erroneous or bounded error behavior
+ -- that are the concern. In formal reference manual terms the
+ -- notion of validity only applies to scalar types.
+
+ if not Is_Scalar_Type (Typ) then
+ return True;
+
+ -- If no validity checking, then everything is considered valid
+
+ elsif not Validity_Checks_On then
+ return True;
+
+ -- Floating-point types are considered valid unless floating-point
+ -- validity checks have been specifically turned on.
+
+ elsif Is_Floating_Point_Type (Typ)
+ and then not Validity_Check_Floating_Point
+ then
+ return True;
+
+ -- If the expression is the value of an object that is known to
+ -- be valid, then clearly the expression value itself is valid.
+
+ elsif Is_Entity_Name (Expr)
+ and then Is_Known_Valid (Entity (Expr))
+ then
+ return True;
+
+ -- If the type is one for which all values are known valid, then
+ -- we are sure that the value is valid except in the slightly odd
+ -- case where the expression is a reference to a variable whose size
+ -- has been explicitly set to a value greater than the object size.
+
+ elsif Is_Known_Valid (Typ) then
+ if Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Variable
+ and then Esize (Entity (Expr)) > Esize (Typ)
+ then
+ return False;
+ else
+ return True;
+ end if;
+
+ -- Integer and character literals always have valid values, where
+ -- appropriate these will be range checked in any case.
+
+ elsif Nkind (Expr) = N_Integer_Literal
+ or else
+ Nkind (Expr) = N_Character_Literal
+ then
+ return True;
+
+ -- If we have a type conversion or a qualification of a known valid
+ -- value, then the result will always be valid.
+
+ elsif Nkind (Expr) = N_Type_Conversion
+ or else
+ Nkind (Expr) = N_Qualified_Expression
+ then
+ return Expr_Known_Valid (Expression (Expr));
+
+ -- The result of any function call or operator is always considered
+ -- valid, since we assume the necessary checks are done by the call.
+
+ elsif Nkind (Expr) in N_Binary_Op
+ or else
+ Nkind (Expr) in N_Unary_Op
+ or else
+ Nkind (Expr) = N_Function_Call
+ then
+ return True;
+
+ -- For all other cases, we do not know the expression is valid
+
+ else
+ return False;
+ end if;
+ end Expr_Known_Valid;
+
+ ----------------
+ -- Find_Check --
+ ----------------
+
+ procedure Find_Check
+ (Expr : Node_Id;
+ Check_Type : Character;
+ Target_Type : Entity_Id;
+ Entry_OK : out Boolean;
+ Check_Num : out Nat;
+ Ent : out Entity_Id;
+ Ofs : out Uint)
+ is
+ function Within_Range_Of
+ (Target_Type : Entity_Id;
+ 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
+ -- that no check against Target_Type is required.
+
+ ---------------------
+ -- Within_Range_Of --
+ ---------------------
+
+ function Within_Range_Of
+ (Target_Type : Entity_Id;
+ Check_Type : Entity_Id) return Boolean
+ is
+ begin
+ if Target_Type = Check_Type then
+ return True;
+
+ else
+ declare
+ Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
+ Thi : constant Node_Id := Type_High_Bound (Target_Type);
+ Clo : constant Node_Id := Type_Low_Bound (Check_Type);
+ Chi : constant Node_Id := Type_High_Bound (Check_Type);
+
+ begin
+ if (Tlo = Clo
+ or else (Compile_Time_Known_Value (Tlo)
+ and then
+ Compile_Time_Known_Value (Clo)
+ and then
+ Expr_Value (Clo) >= Expr_Value (Tlo)))
+ and then
+ (Thi = Chi
+ or else (Compile_Time_Known_Value (Thi)
+ and then
+ Compile_Time_Known_Value (Chi)
+ and then
+ Expr_Value (Chi) <= Expr_Value (Clo)))
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end;
+ end if;
+ end Within_Range_Of;
+
+ -- Start of processing for Find_Check
+
+ begin
+ -- Establish default, to avoid warnings from GCC.
+
+ Check_Num := 0;
+
+ -- Case of expression is simple entity reference
+
+ if Is_Entity_Name (Expr) then
+ Ent := Entity (Expr);
+ Ofs := Uint_0;
+
+ -- Case of expression is entity + known constant
+
+ elsif Nkind (Expr) = N_Op_Add
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ and then Is_Entity_Name (Left_Opnd (Expr))
+ then
+ Ent := Entity (Left_Opnd (Expr));
+ Ofs := Expr_Value (Right_Opnd (Expr));
+
+ -- Case of expression is entity - known constant
+
+ elsif Nkind (Expr) = N_Op_Subtract
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ and then Is_Entity_Name (Left_Opnd (Expr))
+ then
+ Ent := Entity (Left_Opnd (Expr));
+ Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
+
+ -- Any other expression is not of the right form
+
+ else
+ Ent := Empty;
+ Ofs := Uint_0;
+ Entry_OK := False;
+ return;
+ end if;
+
+ -- Come here with expression of appropriate form, check if
+ -- entity is an appropriate one for our purposes.
+
+ if (Ekind (Ent) = E_Variable
+ or else
+ Ekind (Ent) = E_Constant
+ or else
+ Ekind (Ent) = E_Loop_Parameter
+ or else
+ Ekind (Ent) = E_In_Parameter)
+ and then not Is_Library_Level_Entity (Ent)
+ then
+ Entry_OK := True;
+ else
+ Entry_OK := False;
+ return;
+ end if;
+
+ -- See if there is matching check already
+
+ for J in reverse 1 .. Num_Saved_Checks loop
+ declare
+ SC : Saved_Check renames Saved_Checks (J);
+
+ begin
+ if SC.Killed = False
+ and then SC.Entity = Ent
+ and then SC.Offset = Ofs
+ and then SC.Check_Type = Check_Type
+ and then Within_Range_Of (Target_Type, SC.Target_Type)
+ then
+ Check_Num := J;
+ return;
+ end if;
+ end;
+ end loop;
+
+ -- If we fall through entry was not found
+
+ Check_Num := 0;
+ return;
+ end Find_Check;
+
+ ---------------------------------
+ -- Generate_Discriminant_Check --
+ ---------------------------------
+
+ -- Note: the code for this procedure is derived from the
+ -- emit_discriminant_check routine a-trans.c v1.659.
+
+ procedure Generate_Discriminant_Check (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Pref : constant Node_Id := Prefix (N);
+ Sel : constant Node_Id := Selector_Name (N);
+
+ Orig_Comp : constant Entity_Id :=
+ Original_Record_Component (Entity (Sel));
+ -- The original component to be checked
+
+ Discr_Fct : constant Entity_Id :=
+ Discriminant_Checking_Func (Orig_Comp);
+ -- The discriminant checking function
+
+ Discr : Entity_Id;
+ -- One discriminant to be checked in the type
+
+ Real_Discr : Entity_Id;
+ -- Actual discriminant in the call
+
+ Pref_Type : Entity_Id;
+ -- Type of relevant prefix (ignoring private/access stuff)
+
+ Args : List_Id;
+ -- List of arguments for function call
+
+ Formal : Entity_Id;
+ -- Keep track of the formal corresponding to the actual we build
+ -- for each discriminant, in order to be able to perform the
+ -- necessary type conversions.
+
+ Scomp : Node_Id;
+ -- Selected component reference for checking function argument
+
+ begin
+ Pref_Type := Etype (Pref);
+
+ -- Force evaluation of the prefix, so that it does not get evaluated
+ -- twice (once for the check, once for the actual reference). Such a
+ -- double evaluation is always a potential source of inefficiency,
+ -- and is functionally incorrect in the volatile case, or when the
+ -- prefix may have side-effects. An entity or a component of an
+ -- entity requires no evaluation.
+
+ if Is_Entity_Name (Pref) then
+ if Treat_As_Volatile (Entity (Pref)) then
+ Force_Evaluation (Pref, Name_Req => True);
+ end if;
+
+ elsif Treat_As_Volatile (Etype (Pref)) then
+ Force_Evaluation (Pref, Name_Req => True);
+
+ elsif Nkind (Pref) = N_Selected_Component
+ and then Is_Entity_Name (Prefix (Pref))
+ then
+ null;
+
+ else
+ Force_Evaluation (Pref, Name_Req => True);
+ end if;
+
+ -- For a tagged type, use the scope of the original component to
+ -- obtain the type, because ???
+
+ if Is_Tagged_Type (Scope (Orig_Comp)) then
+ Pref_Type := Scope (Orig_Comp);
+
+ -- For an untagged derived type, use the discriminants of the
+ -- parent which have been renamed in the derivation, possibly
+ -- by a one-to-many discriminant constraint.
+ -- For non-tagged type, initially get the Etype of the prefix
+
+ else
+ if Is_Derived_Type (Pref_Type)
+ and then Number_Discriminants (Pref_Type) /=
+ Number_Discriminants (Etype (Base_Type (Pref_Type)))
+ then
+ Pref_Type := Etype (Base_Type (Pref_Type));
+ end if;
+ end if;
+
+ -- We definitely should have a checking function, This routine should
+ -- not be called if no discriminant checking function is present.
+
+ pragma Assert (Present (Discr_Fct));
+
+ -- Create the list of the actual parameters for the call. This list
+ -- is the list of the discriminant fields of the record expression to
+ -- be discriminant checked.
+
+ Args := New_List;
+ Formal := First_Formal (Discr_Fct);
+ Discr := First_Discriminant (Pref_Type);
+ while Present (Discr) loop
+
+ -- If we have a corresponding discriminant field, and a parent
+ -- subtype is present, then we want to use the corresponding
+ -- discriminant since this is the one with the useful value.
+
+ if Present (Corresponding_Discriminant (Discr))
+ and then Ekind (Pref_Type) = E_Record_Type
+ and then Present (Parent_Subtype (Pref_Type))
+ then
+ Real_Discr := Corresponding_Discriminant (Discr);
+ else
+ Real_Discr := Discr;
+ end if;
+
+ -- Construct the reference to the discriminant
+
+ Scomp :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Pref_Type,
+ Duplicate_Subexpr (Pref)),
+ Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
+
+ -- Manually analyze and resolve this selected component. We really
+ -- want it just as it appears above, and do not want the expander
+ -- playing discriminal games etc with this reference. Then we
+ -- append the argument to the list we are gathering.
+
+ Set_Etype (Scomp, Etype (Real_Discr));
+ Set_Analyzed (Scomp, True);
+ Append_To (Args, Convert_To (Etype (Formal), Scomp));
+
+ Next_Formal_With_Extras (Formal);
+ Next_Discriminant (Discr);
+ end loop;
+
+ -- Now build and insert the call
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Discr_Fct, Loc),
+ Parameter_Associations => Args),
+ Reason => CE_Discriminant_Check_Failed));
+ end Generate_Discriminant_Check;
+
+ ---------------------------
+ -- Generate_Index_Checks --
+ ---------------------------
+
+ procedure Generate_Index_Checks (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ A : constant Node_Id := Prefix (N);
+ Sub : Node_Id;
+ Ind : Nat;
+ Num : List_Id;
+
+ begin
+ Sub := First (Expressions (N));
+ Ind := 1;
+ while Present (Sub) loop
+ if Do_Range_Check (Sub) then
+ Set_Do_Range_Check (Sub, False);
+
+ -- Force evaluation except for the case of a simple name of
+ -- a non-volatile entity.
+
+ if not Is_Entity_Name (Sub)
+ or else Treat_As_Volatile (Entity (Sub))
+ then
+ Force_Evaluation (Sub);
+ end if;
+
+ -- Generate a raise of constraint error with the appropriate
+ -- reason and a condition of the form:
+
+ -- Base_Type(Sub) not in array'range (subscript)
+
+ -- Note that the reason we generate the conversion to the
+ -- base type here is that we definitely want the range check
+ -- to take place, even if it looks like the subtype is OK.
+ -- Optimization considerations that allow us to omit the
+ -- check have already been taken into account in the setting
+ -- of the Do_Range_Check flag earlier on.
+
+ if Ind = 1 then
+ Num := No_List;
+ else
+ Num := New_List (Make_Integer_Literal (Loc, Ind));
+ end if;
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd =>
+ Convert_To (Base_Type (Etype (Sub)),
+ Duplicate_Subexpr_Move_Checks (Sub)),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr_Move_Checks (A),
+ Attribute_Name => Name_Range,
+ Expressions => Num)),
+ Reason => CE_Index_Check_Failed));
+ end if;
+
+ Ind := Ind + 1;
+ Next (Sub);
+ end loop;
+ end Generate_Index_Checks;
+
+ --------------------------
+ -- Generate_Range_Check --
+ --------------------------
+
+ procedure Generate_Range_Check
+ (N : Node_Id;
+ Target_Type : Entity_Id;
+ Reason : RT_Exception_Code)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Source_Type : constant Entity_Id := Etype (N);
+ Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
+ Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
+
+ begin
+ -- First special case, if the source type is already within the
+ -- range of the target type, then no check is needed (probably we
+ -- should have stopped Do_Range_Check from being set in the first
+ -- place, but better late than later in preventing junk code!
+
+ -- We do NOT apply this if the source node is a literal, since in
+ -- this case the literal has already been labeled as having the
+ -- subtype of the target.
+
+ if In_Subrange_Of (Source_Type, Target_Type)
+ and then not
+ (Nkind (N) = N_Integer_Literal
+ or else
+ Nkind (N) = N_Real_Literal
+ or else
+ Nkind (N) = N_Character_Literal
+ or else
+ (Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Enumeration_Literal))
+ then
+ return;
+ end if;
+
+ -- We need a check, so force evaluation of the node, so that it does
+ -- not get evaluated twice (once for the check, once for the actual
+ -- reference). Such a double evaluation is always a potential source
+ -- of inefficiency, and is functionally incorrect in the volatile case.
+
+ if not Is_Entity_Name (N)
+ or else Treat_As_Volatile (Entity (N))
+ then
+ Force_Evaluation (N);
+ end if;
+
+ -- The easiest case is when Source_Base_Type and Target_Base_Type
+ -- are the same since in this case we can simply do a direct
+ -- check of the value of N against the bounds of Target_Type.
- elsif Nkind (Parent (Expr)) = N_Assignment_Statement
- and then Expr = Name (Parent (Expr))
- then
- return;
+ -- [constraint_error when N not in Target_Type]
- -- An annoying special case. If this is an out parameter of a scalar
- -- type, then the value is not going to be accessed, therefore it is
- -- inappropriate to do any validity check at the call site.
+ -- Note: this is by far the most common case, for example all cases of
+ -- checks on the RHS of assignments are in this category, but not all
+ -- cases are like this. Notably conversions can involve two types.
- else
- -- Only need to worry about scalar types
+ if Source_Base_Type = Target_Base_Type then
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
+ Reason => Reason));
- if Is_Scalar_Type (Typ) then
- declare
- P : Node_Id;
- N : Node_Id;
- E : Entity_Id;
- F : Entity_Id;
- A : Node_Id;
- L : List_Id;
+ -- Next test for the case where the target type is within the bounds
+ -- of the base type of the source type, since in this case we can
+ -- simply convert these bounds to the base type of T to do the test.
- begin
- -- Find actual argument (which may be a parameter association)
- -- and the parent of the actual argument (the call statement)
+ -- [constraint_error when N not in
+ -- Source_Base_Type (Target_Type'First)
+ -- ..
+ -- Source_Base_Type(Target_Type'Last))]
- N := Expr;
- P := Parent (Expr);
+ -- The conversions will always work and need no check.
- if Nkind (P) = N_Parameter_Association then
- N := P;
- P := Parent (N);
- end if;
+ elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
- -- Only need to worry if we are argument of a procedure
- -- call since functions don't have out parameters.
+ Right_Opnd =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_First)),
+
+ High_Bound =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Last)))),
+ Reason => Reason));
+
+ -- Note that at this stage we now that the Target_Base_Type is
+ -- not in the range of the Source_Base_Type (since even the
+ -- Target_Type itself is not in this range). It could still be
+ -- the case that the Source_Type is in range of the target base
+ -- type, since we have not checked that case.
+
+ -- If that is the case, we can freely convert the source to the
+ -- target, and then test the target result against the bounds.
+
+ elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
+
+ -- We make a temporary to hold the value of the converted
+ -- value (converted to the base type), and then we will
+ -- do the test against this temporary.
+
+ -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
+ -- [constraint_error when Tnn not in Target_Type]
+
+ -- Then the conversion itself is replaced by an occurrence of Tnn
- if Nkind (P) = N_Procedure_Call_Statement then
- L := Parameter_Associations (P);
- E := Entity (Name (P));
+ declare
+ Tnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
- -- Only need to worry if there are indeed actuals, and
- -- if this could be a procedure call, otherwise we cannot
- -- get a match (either we are not an argument, or the
- -- mode of the formal is not OUT). This test also filters
- -- out the generic case.
+ begin
+ Insert_Actions (N, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Object_Definition =>
+ New_Occurrence_Of (Target_Base_Type, Loc),
+ Constant_Present => True,
+ Expression =>
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
+ Expression => Duplicate_Subexpr (N))),
- if Is_Non_Empty_List (L)
- and then Is_Subprogram (E)
- then
- -- This is the loop through parameters, looking to
- -- see if there is an OUT parameter for which we are
- -- the argument.
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd => New_Occurrence_Of (Tnn, Loc),
+ Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
- F := First_Formal (E);
- A := First (L);
+ Reason => Reason)));
- while Present (F) loop
- if Ekind (F) = E_Out_Parameter and then A = N then
- return;
- end if;
+ Rewrite (N, New_Occurrence_Of (Tnn, Loc));
+ end;
- Next_Formal (F);
- Next (A);
- end loop;
- end if;
- end if;
- end;
- end if;
- end if;
+ -- At this stage, we know that we have two scalar types, which are
+ -- directly convertible, and where neither scalar type has a base
+ -- range that is in the range of the other scalar type.
- -- If we fall through, a validity check is required. Note that it would
- -- not be good to set Do_Range_Check, even in contexts where this is
- -- permissible, since this flag causes checking against the target type,
- -- not the source type in contexts such as assignments
+ -- The only way this can happen is with a signed and unsigned type.
+ -- So test for these two cases:
- Insert_Valid_Check (Expr);
- end Ensure_Valid;
+ else
+ -- Case of the source is unsigned and the target is signed
- ----------------------
- -- Expr_Known_Valid --
- ----------------------
+ if Is_Unsigned_Type (Source_Base_Type)
+ and then not Is_Unsigned_Type (Target_Base_Type)
+ then
+ -- If the source is unsigned and the target is signed, then we
+ -- know that the source is not shorter than the target (otherwise
+ -- the source base type would be in the target base type range).
- function Expr_Known_Valid (Expr : Node_Id) return Boolean is
- Typ : constant Entity_Id := Etype (Expr);
+ -- In other words, the unsigned type is either the same size
+ -- as the target, or it is larger. It cannot be smaller.
- begin
- -- Non-scalar types are always consdered valid, since they never
- -- give rise to the issues of erroneous or bounded error behavior
- -- that are the concern. In formal reference manual terms the
- -- notion of validity only applies to scalar types.
+ pragma Assert
+ (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
- if not Is_Scalar_Type (Typ) then
- return True;
+ -- We only need to check the low bound if the low bound of the
+ -- target type is non-negative. If the low bound of the target
+ -- type is negative, then we know that we will fit fine.
- -- If no validity checking, then everything is considered valid
+ -- If the high bound of the target type is negative, then we
+ -- know we have a constraint error, since we can't possibly
+ -- have a negative source.
- elsif not Validity_Checks_On then
- return True;
+ -- With these two checks out of the way, we can do the check
+ -- using the source type safely
- -- Floating-point types are considered valid unless floating-point
- -- validity checks have been specifically turned on.
+ -- This is definitely the most annoying case!
- elsif Is_Floating_Point_Type (Typ)
- and then not Validity_Check_Floating_Point
- then
- return True;
+ -- [constraint_error
+ -- when (Target_Type'First >= 0
+ -- and then
+ -- N < Source_Base_Type (Target_Type'First))
+ -- or else Target_Type'Last < 0
+ -- or else N > Source_Base_Type (Target_Type'Last)];
- -- If the expression is the value of an object that is known to
- -- be valid, then clearly the expression value itself is valid.
+ -- We turn off all checks since we know that the conversions
+ -- will work fine, given the guards for negative values.
- elsif Is_Entity_Name (Expr)
- and then Is_Known_Valid (Entity (Expr))
- then
- return True;
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Or_Else (Loc,
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_And_Then (Loc,
+ Left_Opnd => Make_Op_Ge (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_First),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+
+ Right_Opnd =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_First)))),
+
+ Right_Opnd =>
+ Make_Op_Lt (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Last),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
+
+ Right_Opnd =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Last)))),
- -- If the type is one for which all values are known valid, then
- -- we are sure that the value is valid except in the slightly odd
- -- case where the expression is a reference to a variable whose size
- -- has been explicitly set to a value greater than the object size.
+ Reason => Reason),
+ Suppress => All_Checks);
+
+ -- Only remaining possibility is that the source is signed and
+ -- the target is unsigned
- elsif Is_Known_Valid (Typ) then
- if Is_Entity_Name (Expr)
- and then Ekind (Entity (Expr)) = E_Variable
- and then Esize (Entity (Expr)) > Esize (Typ)
- then
- return False;
else
- return True;
- end if;
+ pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
+ and then Is_Unsigned_Type (Target_Base_Type));
- -- Integer and character literals always have valid values, where
- -- appropriate these will be range checked in any case.
+ -- If the source is signed and the target is unsigned, then
+ -- we know that the target is not shorter than the source
+ -- (otherwise the target base type would be in the source
+ -- base type range).
- elsif Nkind (Expr) = N_Integer_Literal
- or else
- Nkind (Expr) = N_Character_Literal
- then
- return True;
+ -- In other words, the unsigned type is either the same size
+ -- as the target, or it is larger. It cannot be smaller.
- -- If we have a type conversion or a qualification of a known valid
- -- value, then the result will always be valid.
+ -- Clearly we have an error if the source value is negative
+ -- since no unsigned type can have negative values. If the
+ -- source type is non-negative, then the check can be done
+ -- using the target type.
- elsif Nkind (Expr) = N_Type_Conversion
- or else
- Nkind (Expr) = N_Qualified_Expression
- then
- return Expr_Known_Valid (Expression (Expr));
+ -- Tnn : constant Target_Base_Type (N) := Target_Type;
- -- The result of any function call or operator is always considered
- -- valid, since we assume the necessary checks are done by the call.
+ -- [constraint_error
+ -- when N < 0 or else Tnn not in Target_Type];
- elsif Nkind (Expr) in N_Binary_Op
- or else
- Nkind (Expr) in N_Unary_Op
- or else
- Nkind (Expr) = N_Function_Call
- then
- return True;
+ -- We turn off all checks for the conversion of N to the
+ -- target base type, since we generate the explicit check
+ -- to ensure that the value is non-negative
- -- For all other cases, we do not know the expression is valid
+ declare
+ Tnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
- else
- return False;
+ begin
+ Insert_Actions (N, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Object_Definition =>
+ New_Occurrence_Of (Target_Base_Type, Loc),
+ Constant_Present => True,
+ Expression =>
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Target_Base_Type, Loc),
+ Expression => Duplicate_Subexpr (N))),
+
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+
+ Right_Opnd =>
+ Make_Not_In (Loc,
+ Left_Opnd => New_Occurrence_Of (Tnn, Loc),
+ Right_Opnd =>
+ New_Occurrence_Of (Target_Type, Loc))),
+
+ Reason => Reason)),
+ Suppress => All_Checks);
+
+ -- Set the Etype explicitly, because Insert_Actions may
+ -- have placed the declaration in the freeze list for an
+ -- enclosing construct, and thus it is not analyzed yet.
+
+ Set_Etype (Tnn, Target_Base_Type);
+ Rewrite (N, New_Occurrence_Of (Tnn, Loc));
+ end;
+ end if;
end if;
- end Expr_Known_Valid;
+ end Generate_Range_Check;
---------------------
-- Get_Discriminal --
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
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr (Ck_Node),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Index_Checks
- or else (Present (E) and then Suppress_Index_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Index_Check);
+ else
+ return Scope_Suppress (Index_Check);
+ end if;
end Index_Checks_Suppressed;
----------------
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr (Exp, Name_Req => True),
+ Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
Attribute_Name => Name_Valid)),
Reason => CE_Invalid_Data),
Suppress => All_Checks);
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 --
--------------------------
Set_Is_Static_Expression (R_Cno, Stat);
end Install_Static_Check;
+ ---------------------
+ -- Kill_All_Checks --
+ ---------------------
+
+ procedure Kill_All_Checks is
+ begin
+ if Debug_Flag_CC then
+ w ("Kill_All_Checks");
+ end if;
+
+ -- We reset the number of saved checks to zero, and also modify
+ -- all stack entries for statement ranges to indicate that the
+ -- number of checks at each level is now zero.
+
+ Num_Saved_Checks := 0;
+
+ for J in 1 .. Saved_Checks_TOS loop
+ Saved_Checks_Stack (J) := 0;
+ end loop;
+ end Kill_All_Checks;
+
+ -----------------
+ -- Kill_Checks --
+ -----------------
+
+ procedure Kill_Checks (V : Entity_Id) is
+ begin
+ if Debug_Flag_CC then
+ w ("Kill_Checks for entity", Int (V));
+ end if;
+
+ for J in 1 .. Num_Saved_Checks loop
+ if Saved_Checks (J).Entity = V then
+ if Debug_Flag_CC then
+ w (" Checks killed for saved check ", J);
+ end if;
+
+ Saved_Checks (J).Killed := True;
+ end if;
+ end loop;
+ end Kill_Checks;
+
------------------------------
-- Length_Checks_Suppressed --
------------------------------
function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Length_Checks
- or else (Present (E) and then Suppress_Length_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Length_Check);
+ else
+ return Scope_Suppress (Length_Check);
+ end if;
end Length_Checks_Suppressed;
--------------------------------
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Overflow_Checks
- or else (Present (E) and then Suppress_Overflow_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Overflow_Check);
+ else
+ return Scope_Suppress (Overflow_Check);
+ end if;
end Overflow_Checks_Suppressed;
-----------------
(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
function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- -- Note: for now we always suppress range checks on Vax float types,
- -- since Gigi does not know how to generate these checks.
+ if Present (E) then
+
+ -- Note: for now we always suppress range checks on Vax float types,
+ -- since Gigi does not know how to generate these checks.
+
+ if Vax_Float (E) then
+ return True;
+ elsif Kill_Range_Checks (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Range_Check);
+ end if;
+ end if;
- return Scope_Suppress.Range_Checks
- or else (Present (E) and then Suppress_Range_Checks (E))
- or else Vax_Float (E);
+ return Scope_Suppress (Range_Check);
end Range_Checks_Suppressed;
-------------------
procedure Remove_Checks (Expr : Node_Id) is
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
function Process (N : Node_Id) return Traverse_Result;
-- Process a single node during the traversal
return Skip;
when N_Attribute_Reference =>
- Set_Do_Access_Check (N, False);
Set_Do_Overflow_Check (N, False);
- when N_Explicit_Dereference =>
- Set_Do_Access_Check (N, False);
-
when N_Function_Call =>
Set_Do_Tag_Check (N, False);
- when N_Indexed_Component =>
- Set_Do_Access_Check (N, False);
-
when N_Op =>
Set_Do_Overflow_Check (N, False);
return Skip;
when N_Selected_Component =>
- Set_Do_Access_Check (N, False);
Set_Do_Discriminant_Check (N, False);
- when N_Slice =>
- Set_Do_Access_Check (N, False);
-
when N_Type_Conversion =>
- Set_Do_Length_Check (N, False);
+ Set_Do_Length_Check (N, False);
+ Set_Do_Tag_Check (N, False);
Set_Do_Overflow_Check (N, False);
- Set_Do_Tag_Check (N, False);
when others =>
null;
(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
-- entity, even if its value is not a static constant. This includes the
- -- case of a discriminal reference within an init_proc. Removes some
+ -- case of a discriminal reference within an init proc. Removes some
-- obviously superfluous checks.
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 Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
+ Pt : constant Entity_Id := Scope (Scope (E));
N : Node_Id;
E1 : Entity_Id := E;
- Pt : Entity_Id := Scope (Scope (E));
begin
if Ekind (Scope (E)) = E_Record_Type
if Do_Expand then
if not Is_Entity_Name (Lo) then
- Lo := Duplicate_Subexpr (Lo);
+ Lo := Duplicate_Subexpr_No_Checks (Lo);
end if;
if not Is_Entity_Name (Hi) then
- Lo := Duplicate_Subexpr (Hi);
+ Lo := Duplicate_Subexpr_No_Checks (Hi);
end if;
N :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Length,
Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
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
-- T_Typ'Length = string-literal-length
- if Nkind (Expr_Actual) = N_String_Literal then
+ if Nkind (Expr_Actual) = N_String_Literal
+ and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
+ then
Cond :=
Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (T_Typ, 1),
elsif Is_Constrained (Exptyp) then
declare
- L_Index : Node_Id;
- R_Index : Node_Id;
- Ndims : Nat := Number_Dimensions (T_Typ);
-
- L_Low : Node_Id;
- L_High : Node_Id;
- R_Low : Node_Id;
- R_High : Node_Id;
-
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
+
+ L_Index : Node_Id;
+ R_Index : Node_Id;
+ L_Low : Node_Id;
+ L_High : Node_Id;
+ R_Low : Node_Id;
+ R_High : Node_Id;
L_Length : Uint;
R_Length : Uint;
+ Ref_Node : Node_Id;
begin
+
+ -- At the library level, we need to ensure that the
+ -- type of the object is elaborated before the check
+ -- itself is emitted. This is only done if the object
+ -- is in the current compilation unit, otherwise the
+ -- type is frozen and elaborated in its unit.
+
+ if Is_Itype (Exptyp)
+ and then
+ Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
+ and then
+ 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));
+ Set_Itype (Ref_Node, Exptyp);
+ Insert_Action (Ck_Node, Ref_Node);
+ end if;
+
L_Index := First_Index (T_Typ);
R_Index := First_Index (Exptyp);
else
declare
- Ndims : Nat := Number_Dimensions (T_Typ);
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
begin
-- Build the condition for the explicit dereference case
(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 Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
-- Returns expression to compute:
- -- N'First or N'Last using Duplicate_Subexpr
+ -- N'First or N'Last using Duplicate_Subexpr_No_Checks
function Range_E_Cond
(Exptyp : Entity_Id;
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
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd =>
- Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
+ Convert_To (Base_Type (Typ),
+ Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Convert_To (Base_Type (Typ),
Get_E_First_Or_Last (Typ, 0, Name_First))),
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd =>
- Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
+ Convert_To (Base_Type (Typ),
+ Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Convert_To
(Base_Type (Typ),
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);
Make_Op_Lt (Loc,
Left_Opnd =>
Convert_To
- (Base_Type (Typ), Duplicate_Subexpr (LB)),
+ (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd =>
Convert_To
Make_Op_Gt (Loc,
Left_Opnd =>
Convert_To
- (Base_Type (Typ), Duplicate_Subexpr (HB)),
+ (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
Right_Opnd =>
Convert_To
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;
if Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_Discriminant
then
- return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+ -- If this is a task discriminant, and we are the body, we must
+ -- retrieve the corresponding body discriminal. This is another
+ -- consequence of the early creation of discriminals, and the
+ -- need to generate constraint checks before their declarations
+ -- are made visible.
+
+ if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
+ declare
+ Tsk : constant Entity_Id :=
+ Corresponding_Concurrent_Type
+ (Scope (Entity (Bound)));
+ Disc : Entity_Id;
+
+ begin
+ if In_Open_Scopes (Tsk)
+ and then Has_Completion (Tsk)
+ then
+ -- Find discriminant of original task, and use its
+ -- current discriminal, which is the renaming within
+ -- the task body.
+
+ Disc := First_Discriminant (Tsk);
+ while Present (Disc) loop
+ if Chars (Disc) = Chars (Entity (Bound)) then
+ Set_Scope (Discriminal (Disc), Tsk);
+ return New_Occurrence_Of (Discriminal (Disc), Loc);
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ -- That loop should always succeed in finding a matching
+ -- entry and returning. Fatal error if not.
+
+ raise Program_Error;
+
+ else
+ return
+ New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+ end if;
+ end;
+ else
+ return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+ end if;
elsif Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_In_Parameter
return Make_Integer_Literal (Loc, Intval (Bound));
else
- return Duplicate_Subexpr (Bound);
+ return Duplicate_Subexpr_No_Checks (Bound);
end if;
end Get_E_First_Or_Last;
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
-
end Get_N_First;
----------------
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
+ 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
-- the record declaration, it is a use of the discriminant
-- in a constraint of a component, and nothing can be
-- checked here. The check will be emitted within the
- -- init_proc. Before then, the discriminal has no real
+ -- init proc. Before then, the discriminal has no real
-- meaning.
if Nkind (LB) = N_Identifier
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
- Left_Opnd => Duplicate_Subexpr (HB),
- Right_Opnd => Duplicate_Subexpr (LB)),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (HB),
+ Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd => Cond);
end;
elsif Is_Constrained (Exptyp) then
declare
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
+
L_Index : Node_Id;
R_Index : Node_Id;
- Ndims : Nat := Number_Dimensions (T_Typ);
-
- L_Low : Node_Id;
- L_High : Node_Id;
- R_Low : Node_Id;
- R_High : Node_Id;
+ L_Low : Node_Id;
+ L_High : Node_Id;
+ R_Low : Node_Id;
+ R_High : Node_Id;
begin
L_Index := First_Index (T_Typ);
else
declare
- Ndims : Nat := Number_Dimensions (T_Typ);
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
begin
-- Build the condition for the explicit dereference case
then
null;
+ -- If null range, no check needed.
+ elsif
+ Compile_Time_Known_Value (High_Bound (Opnd_Index))
+ and then
+ Compile_Time_Known_Value (Low_Bound (Opnd_Index))
+ and then
+ Expr_Value (High_Bound (Opnd_Index)) <
+ Expr_Value (Low_Bound (Opnd_Index))
+ then
+ null;
+
elsif Is_Out_Of_Range
(Low_Bound (Opnd_Index), Etype (Targ_Index))
or else
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Storage_Checks
- or else (Present (E) and then Suppress_Storage_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Storage_Check);
+ else
+ return Scope_Suppress (Storage_Check);
+ end if;
end Storage_Checks_Suppressed;
---------------------------
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Tag_Checks
- or else (Present (E) and then Suppress_Tag_Checks (E));
+ if Present (E) then
+ if Kill_Tag_Checks (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Tag_Check);
+ end if;
+ end if;
+
+ return Scope_Suppress (Tag_Check);
end Tag_Checks_Suppressed;
end Checks;
OSDN Git Service
