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

treepr.adb: Use new subtype N_Membership_Test 

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* treepr.adb: Use new subtype N_Membership_Test

        * checks.ads, checks.adb: Add definition for Validity_Check
        (Range_Or_Validity_Checks_Suppressed): New function
        (Ensure_Valid): Test Validity_Check suppressed
        (Insert_Valid_Check): Test Validity_Check suppressed
        (Insert_Valid_Check): Preserve Do_Range_Check flag
	(Validity_Check_Range): New procedure
	(Expr_Known_Valid): Result of membership test is always valid
	(Selected_Range_Checks): Range checks cannot be applied to discriminants
	by themselves. Disabling those checks must also be done for task types,
	where discriminants may be used for the bounds of entry families.
	(Apply_Address_Clause_Check): Remove side-effects if address expression
	is non-static and is not the name of a declared constant.
	(Null_Exclusion_Static_Checks): Extend to handle Function_Specification.
	Code cleanup and new error messages.
	(Enable_Range_Check): Test for some cases of suppressed checks
	(Generate_Index_Checks): Suppress index checks if index checks are
	suppressed for array object or array type.
	(Apply_Selected_Length_Checks): Give warning for compile-time detected
	length check failure, even if checks are off.
	(Ensure_Valid): Do not generate a check on an indexed component whose
	prefix is a packed boolean array.
	* checks.adb: (Alignment_Checks_Suppressed): New function
	(Apply_Address_Clause_Check): New procedure, this is a completely
	rewritten replacement for Apply_Alignment_Check
	(Get_E_Length/Get_E_First_Or_Last): Add missing barrier to ensure that
	we request a discriminal value only in case of discriminants.
	(Apply_Discriminant_Check): For Ada_05, only call Get_Actual_Subtype for
	assignments where the target subtype is unconstrained and the target
	object is a parameter or dereference (other aliased cases are known
	to be unconstrained).

From-SVN: r118248
This commit is contained in:
Robert Dewar 2006-10-31 18:51:20 +01:00 committed by Arnaud Charlet
parent ff9625b0fa
commit c064e06602
3 changed files with 610 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

653
gcc/ada/checks.adb
View File

@ -268,6 +268,10 @@ package body Checks is
-- of the enclosing protected operation). This clumsy transformation is
-- needed because privals are created too late and their actual subtypes
-- are not available when analysing the bodies of the protected operations.
-- This function is called whenever the bound is an entity and the scope
-- indicates a protected operation. If the bound is an in-parameter of
-- a protected operation that is not a prival, the function returns the
-- bound itself.
-- To be cleaned up???
function Guard_Access
@ -282,6 +286,12 @@ package body Checks is
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
-- Constraint_Error node.
function Range_Or_Validity_Checks_Suppressed
(Expr : Node_Id) return Boolean;
-- Returns True if either range or validity checks or both are suppressed
-- for the type of the given expression, or, if the expression is the name
-- of an entity, if these checks are suppressed for the entity.
function Selected_Length_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
@ -326,6 +336,19 @@ package body Checks is
end if;
end Accessibility_Checks_Suppressed;
---------------------------------
-- Alignment_Checks_Suppressed --
---------------------------------
function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Alignment_Check);
else
return Scope_Suppress (Alignment_Check);
end if;
end Alignment_Checks_Suppressed;
-------------------------
-- Append_Range_Checks --
-------------------------
@ -449,36 +472,74 @@ package body Checks is
end if;
end Apply_Accessibility_Check;
---------------------------
-- Apply_Alignment_Check --
---------------------------
--------------------------------
-- Apply_Address_Clause_Check --
--------------------------------
procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
AC : constant Node_Id := Address_Clause (E);
Loc : constant Source_Ptr := Sloc (AC);
Typ : constant Entity_Id := Etype (E);
Expr : Node_Id;
Loc : Source_Ptr;
Aexp : constant Node_Id := Expression (AC);
Alignment_Required : constant Boolean := Maximum_Alignment > 1;
-- Constant to show whether target requires alignment checks
Expr : Node_Id;
-- Address expression (not necessarily the same as Aexp, for example
-- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant.
Size_Warning_Output : Boolean := False;
-- If we output a size warning we set this True, to stop generating
-- what is likely to be an unuseful redundant alignment warning.
procedure Compile_Time_Bad_Alignment;
-- Post error warnings when alignment is known to be incompatible. Note
-- that we do not go as far as inserting a raise of Program_Error since
-- this is an erroneous case, and it may happen that we are lucky and an
-- underaligned address turns out to be OK after all. Also this warning
-- is suppressed if we already complained about the size.
--------------------------------
-- Compile_Time_Bad_Alignment --
--------------------------------
procedure Compile_Time_Bad_Alignment is
begin
if not Size_Warning_Output
and then Address_Clause_Overlay_Warnings
then
Error_Msg_FE
("?specified address for& may be inconsistent with alignment ",
Aexp, E);
Error_Msg_FE
("\?program execution may be erroneous ('R'M 13.3(27))",
Aexp, E);
end if;
end Compile_Time_Bad_Alignment;
-- Start of processing for Apply_Address_Check
begin
-- See if check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed
-- First obtain expression from address clause
if No (AC)
or else not Check_Address_Alignment (AC)
or else not Alignment_Required
then
return;
end if;
Loc := Sloc (AC);
Expr := Expression (AC);
if Nkind (Expr) = N_Unchecked_Type_Conversion then
-- The following loop digs for the real expression to use in the check
loop
-- For constant, get constant expression
if Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Constant
then
Expr := Constant_Value (Entity (Expr));
-- For unchecked conversion, get result to convert
elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
Expr := Expression (Expr);
-- For (common case) of To_Address call, get argument
elsif Nkind (Expr) = N_Function_Call
and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
@ -488,10 +549,76 @@ package body Checks is
if Nkind (Expr) = N_Parameter_Association then
Expr := Explicit_Actual_Parameter (Expr);
end if;
-- We finally have the real expression
else
exit;
end if;
end loop;
-- Output a warning if we have the situation of
-- for X'Address use Y'Address
-- and X and Y both have known object sizes, and Y is smaller than X
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
and then Is_Entity_Name (Prefix (Expr))
then
declare
Exp_Ent : constant Entity_Id := Entity (Prefix (Expr));
Obj_Size : Uint := No_Uint;
Exp_Size : Uint := No_Uint;
begin
if Known_Esize (E) then
Obj_Size := Esize (E);
elsif Known_Esize (Etype (E)) then
Obj_Size := Esize (Etype (E));
end if;
-- Here Expr is the address value. See if we know that the
-- value is unacceptable at compile time.
if Known_Esize (Exp_Ent) then
Exp_Size := Esize (Exp_Ent);
elsif Known_Esize (Etype (Exp_Ent)) then
Exp_Size := Esize (Etype (Exp_Ent));
end if;
if Obj_Size /= No_Uint
and then Exp_Size /= No_Uint
and then Obj_Size > Exp_Size
and then not Warnings_Off (E)
then
if Address_Clause_Overlay_Warnings then
Error_Msg_FE
("?& overlays smaller object", Aexp, E);
Error_Msg_FE
("\?program execution may be erroneous", Aexp, E);
Size_Warning_Output := True;
end if;
end if;
end;
end if;
-- See if alignment check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed.
-- Note: we do not check for checks suppressed here, since that check
-- was done in Sem_Ch13 when the address clause was proceeds. We are
-- only called if checks were not suppressed. The reason for this is
-- that we have to delay the call to Apply_Alignment_Check till freeze
-- time (so that all types etc are elaborated), but we have to check
-- the status of check suppressing at the point of the address clause.
if No (AC)
or else not Check_Address_Alignment (AC)
or else Maximum_Alignment = 1
then
return;
end if;
-- See if we know that Expr is a bad alignment at compile time
if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ))
@ -508,22 +635,57 @@ package body Checks is
end if;
if Expr_Value (Expr) mod AL /= 0 then
Insert_Action (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Misaligned_Address_Value));
Error_Msg_NE
("?specified address for& not " &
"consistent with alignment ('R'M 13.3(27))", Expr, E);
Compile_Time_Bad_Alignment;
else
return;
end if;
end;
-- Here we do not know if the value is acceptable, generate
-- code to raise PE if alignment is inappropriate.
-- If the expression has the form X'Address, then we can find out if
-- the object X has an alignment that is compatible with the object E.
elsif Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
then
declare
AR : constant Alignment_Result :=
Has_Compatible_Alignment (E, Prefix (Expr));
begin
if AR = Known_Compatible then
return;
elsif AR = Known_Incompatible then
Compile_Time_Bad_Alignment;
end if;
end;
end if;
-- Here we do not know if the value is acceptable. Stricly we don't have
-- to do anything, since if the alignment is bad, we have an erroneous
-- program. However we are allowed to check for erroneous conditions and
-- we decide to do this by default if the check is not suppressed.
-- However, don't do the check if elaboration code is unwanted
if Restriction_Active (No_Elaboration_Code) then
return;
-- Generate a check to raise PE if alignment may be inappropriate
else
-- Skip generation of this code if we don't want elab code
-- If the original expression is a non-static constant, use the
-- name of the constant itself rather than duplicating its
-- defining expression, which was extracted above..
if Is_Entity_Name (Expression (AC))
and then Ekind (Entity (Expression (AC))) = E_Constant
and then
Nkind (Parent (Entity (Expression (AC)))) = N_Object_Declaration
then
Expr := New_Copy_Tree (Expression (AC));
else
Remove_Side_Effects (Expr);
end if;
if not Restriction_Active (No_Elaboration_Code) then
Insert_After_And_Analyze (N,
Make_Raise_Program_Error (Loc,
Condition =>
@ -532,8 +694,7 @@ package body Checks is
Make_Op_Mod (Loc,
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Integer_Address),
Duplicate_Subexpr_No_Checks (Expr)),
(RTE (RE_Integer_Address), Expr),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc),
@ -541,15 +702,16 @@ package body Checks is
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Reason => PE_Misaligned_Address_Value),
Suppress => All_Checks);
end if;
end if;
return;
end if;
exception
-- If we have some missing run time component in configurable run time
-- mode then just skip the check (it is not required in any case).
when RE_Not_Available =>
return;
end Apply_Alignment_Check;
end Apply_Address_Clause_Check;
-------------------------------------
-- Apply_Arithmetic_Overflow_Check --
@ -1125,15 +1287,26 @@ package body Checks is
end if;
end if;
-- If an assignment target is present, then we need to generate
-- the actual subtype if the target is a parameter or aliased
-- object with an unconstrained nominal subtype.
-- If an assignment target is present, then we need to generate the
-- actual subtype if the target is a parameter or aliased object with
-- an unconstrained nominal subtype.
-- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
-- subtype to the parameter and dereference cases, since other aliased
-- objects are unconstrained (unless the nominal subtype is explicitly
-- constrained). (But we also need to test for renamings???)
if Present (Lhs)
and then (Present (Param_Entity (Lhs))
or else (not Is_Constrained (T_Typ)
or else (Ada_Version < Ada_05
and then not Is_Constrained (T_Typ)
and then Is_Aliased_View (Lhs)
and then not Is_Aliased_Unconstrained_Component))
and then not Is_Aliased_Unconstrained_Component)
or else (Ada_Version >= Ada_05
and then not Is_Constrained (T_Typ)
and then Nkind (Lhs) = N_Explicit_Dereference
and then Nkind (Original_Node (Lhs)) /=
N_Function_Call))
then
T_Typ := Get_Actual_Subtype (Lhs);
end if;
@ -1950,14 +2123,28 @@ package body Checks is
then
Cond := Condition (R_Cno);
if not Has_Dynamic_Length_Check (Ck_Node)
and then Checks_On
then
-- Case where node does not now have a dynamic check
if not Has_Dynamic_Length_Check (Ck_Node) then
-- If checks are on, just insert the check
if Checks_On then
Insert_Action (Ck_Node, R_Cno);
if not Do_Static then
Set_Has_Dynamic_Length_Check (Ck_Node);
end if;
-- If checks are off, then analyze the length check after
-- temporarily attaching it to the tree in case the relevant
-- condition can be evaluted at compile time. We still want a
-- compile time warning in this case.
else
Set_Parent (R_Cno, Ck_Node);
Analyze (R_Cno);
end if;
end if;
-- Output a warning if the condition is known to be True
@ -2599,65 +2786,74 @@ package body Checks is
----------------------------------
procedure Null_Exclusion_Static_Checks (N : Node_Id) is
Error_Node : Node_Id;
Expr : Node_Id;
Has_Null : constant Boolean := Has_Null_Exclusion (N);
K : constant Node_Kind := Nkind (N);
Typ : Entity_Id;
Related_Nod : Node_Id;
Has_Null_Exclusion : Boolean := False;
begin
pragma Assert (K = N_Parameter_Specification
or else K = N_Object_Declaration
pragma Assert
(K = N_Component_Declaration
or else K = N_Discriminant_Specification
or else K = N_Component_Declaration);
or else K = N_Function_Specification
or else K = N_Object_Declaration
or else K = N_Parameter_Specification);
if K = N_Function_Specification then
Typ := Etype (Defining_Entity (N));
else
Typ := Etype (Defining_Identifier (N));
pragma Assert (Is_Access_Type (Typ)
or else (K = N_Object_Declaration and then Is_Array_Type (Typ)));
end if;
case K is
when N_Parameter_Specification =>
Related_Nod := Parameter_Type (N);
Has_Null_Exclusion := Null_Exclusion_Present (N);
when N_Object_Declaration =>
Related_Nod := Object_Definition (N);
Has_Null_Exclusion := Null_Exclusion_Present (N);
when N_Discriminant_Specification =>
Related_Nod := Discriminant_Type (N);
Has_Null_Exclusion := Null_Exclusion_Present (N);
when N_Component_Declaration =>
if Present (Access_Definition (Component_Definition (N))) then
Related_Nod := Component_Definition (N);
Has_Null_Exclusion :=
Null_Exclusion_Present
(Access_Definition (Component_Definition (N)));
Error_Node := Component_Definition (N);
else
Related_Nod :=
Subtype_Indication (Component_Definition (N));
Has_Null_Exclusion :=
Null_Exclusion_Present (Component_Definition (N));
Error_Node := Subtype_Indication (Component_Definition (N));
end if;
when N_Discriminant_Specification =>
Error_Node := Discriminant_Type (N);
when N_Function_Specification =>
Error_Node := Result_Definition (N);
when N_Object_Declaration =>
Error_Node := Object_Definition (N);
when N_Parameter_Specification =>
Error_Node := Parameter_Type (N);
when others =>
raise Program_Error;
end case;
-- Enforce legality rule 3.10 (14/1): A null_exclusion is only allowed
-- of the access subtype does not exclude null.
if Has_Null then
if Has_Null_Exclusion
and then Can_Never_Be_Null (Typ)
-- Enforce legality rule 3.10 (13): A null exclusion can only be
-- applied to an access [sub]type.
-- No need to check itypes that have the null-excluding attribute
-- because they were checked at their point of creation
if not Is_Access_Type (Typ) then
Error_Msg_N
("null-exclusion must be applied to an access type",
Error_Node);
-- Enforce legality rule 3.10 (14/1): A null exclusion can only
-- be applied to a [sub]type that does not exclude null already.
elsif Can_Never_Be_Null (Typ)
-- No need to check itypes that have a null exclusion because
-- they are already examined at their point of creation.
and then not Is_Itype (Typ)
then
Error_Msg_N
("(Ada 2005) already a null-excluding type", Related_Nod);
("null-exclusion cannot be applied to a null excluding type",
Error_Node);
end if;
end if;
-- Check that null-excluding objects are always initialized
@ -2678,46 +2874,44 @@ package body Checks is
Reason => CE_Null_Not_Allowed);
end if;
-- Check that the null value is not used as a single expression to
-- assignate a value to a null-excluding component, formal or object;
-- otherwise generate a warning message at the sloc of Related_Nod and
-- replace Expression (N) by an N_Contraint_Error node.
-- Check that a null-excluding component, formal or object is not
-- being assigned a null value. Otherwise generate a warning message
-- and replace Expression (N) by a N_Contraint_Error node.
declare
Expr : constant Node_Id := Expression (N);
if K /= N_Function_Specification then
Expr := Expression (N);
begin
if Present (Expr)
and then Nkind (Expr) = N_Null
then
case K is
when N_Discriminant_Specification |
N_Component_Declaration =>
when N_Component_Declaration |
N_Discriminant_Specification =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) NULL not allowed in"
& " null-excluding components?",
Reason => CE_Null_Not_Allowed);
when N_Parameter_Specification =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) NULL not allowed in"
& " null-excluding formals?",
Msg => "(Ada 2005) NULL not allowed " &
"in null-excluding components?",
Reason => CE_Null_Not_Allowed);
when N_Object_Declaration =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) NULL not allowed in"
& " null-excluding objects?",
Msg => "(Ada 2005) NULL not allowed " &
"in null-excluding objects?",
Reason => CE_Null_Not_Allowed);
when N_Parameter_Specification =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) NULL not allowed " &
"in null-excluding formals?",
Reason => CE_Null_Not_Allowed);
when others =>
null;
end case;
end if;
end;
end if;
end Null_Exclusion_Static_Checks;
----------------------------------
@ -3461,6 +3655,41 @@ package body Checks is
return;
end if;
-- Check for various cases where we should suppress the range check
-- No check if range checks suppressed for type of node
if Present (Etype (N))
and then Range_Checks_Suppressed (Etype (N))
then
return;
-- No check if node is an entity name, and range checks are suppressed
-- for this entity, or for the type of this entity.
elsif Is_Entity_Name (N)
and then (Range_Checks_Suppressed (Entity (N))
or else Range_Checks_Suppressed (Etype (Entity (N))))
then
return;
-- No checks if index of array, and index checks are suppressed for
-- the array object or the type of the array.
elsif Nkind (Parent (N)) = N_Indexed_Component then
declare
Pref : constant Node_Id := Prefix (Parent (N));
begin
if Is_Entity_Name (Pref)
and then Index_Checks_Suppressed (Entity (Pref))
then
return;
elsif Index_Checks_Suppressed (Etype (Pref)) then
return;
end if;
end;
end if;
-- Debug trace output
if Debug_Flag_CC then
@ -3655,11 +3884,9 @@ package body Checks is
if not Validity_Checks_On then
return;
-- Ignore call if range checks suppressed on entity in question
-- Ignore call if range or validity checks suppressed on entity or type
elsif Is_Entity_Name (Expr)
and then Range_Checks_Suppressed (Entity (Expr))
then
elsif Range_Or_Validity_Checks_Suppressed (Expr) then
return;
-- No check required if expression is from the expander, we assume
@ -3683,11 +3910,6 @@ package body Checks is
elsif Expr_Known_Valid (Expr) then
return;
-- No check required if checks off
elsif Range_Checks_Suppressed (Typ) then
return;
-- Ignore case of enumeration with holes where the flag is set not
-- to worry about holes, since no special validity check is needed
@ -3713,6 +3935,22 @@ package body Checks is
then
return;
-- If the expression denotes a component of a packed boolean arrray,
-- no possible check applies. We ignore the old ACATS chestnuts that
-- involve Boolean range True..True.
-- Note: validity checks are generated for expressions that yield a
-- scalar type, when it is possible to create a value that is outside of
-- the type. If this is a one-bit boolean no such value exists. This is
-- an optimization, and it also prevents compiler blowing up during the
-- elaboration of improperly expanded packed array references.
elsif Nkind (Expr) = N_Indexed_Component
and then Is_Bit_Packed_Array (Etype (Prefix (Expr)))
and then Root_Type (Etype (Expr)) = Standard_Boolean
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.
@ -3771,7 +4009,6 @@ package body Checks is
F := First_Formal (E);
A := First (L);
while Present (F) loop
if Ekind (F) = E_Out_Parameter and then A = N then
return;
@ -3786,10 +4023,7 @@ package body Checks is
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
-- If we fall through, a validity check is required
Insert_Valid_Check (Expr);
end Ensure_Valid;
@ -3835,6 +4069,17 @@ package body Checks is
then
return True;
-- References to discriminants are always considered valid. The value
-- of a discriminant gets checked when the object is built. Within the
-- record, we consider it valid, and it is important to do so, since
-- otherwise we can try to generate bogus validity checks which
-- reference discriminants out of scope.
elsif Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Discriminant
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
@ -3873,9 +4118,7 @@ package body Checks is
-- on floating-point operations, we must also check when the operation
-- is the right-hand side of an assignment, or is an actual in a call.
elsif
Nkind (Expr) in N_Binary_Op or else Nkind (Expr) in N_Unary_Op
then
elsif Nkind (Expr) in N_Op then
if Is_Floating_Point_Type (Typ)
and then Validity_Check_Floating_Point
and then
@ -3888,6 +4131,12 @@ package body Checks is
return True;
end if;
-- The result of a membership test is always valid, since it is true
-- or false, there are no other possibilities.
elsif Nkind (Expr) in N_Membership_Test then
return True;
-- For all other cases, we do not know the expression is valid
else
@ -4200,6 +4449,16 @@ package body Checks is
Num : List_Id;
begin
-- Ignore call if index checks suppressed for array object or type
if (Is_Entity_Name (A) and then Index_Checks_Suppressed (Entity (A)))
or else Index_Checks_Suppressed (Etype (A))
then
return;
end if;
-- Generate the checks
Sub := First (Expressions (N));
Ind := 1;
while Present (Sub) loop
@ -4594,6 +4853,13 @@ package body Checks is
end if;
end if;
-- The bound can be a bona fide parameter of a protected operation,
-- rather than a prival encoded as an in-parameter.
if No (Discriminal_Link (Entity (Bound))) then
return Bound;
end if;
D := First_Discriminant (Sc);
while Present (D)
@ -4739,8 +5005,8 @@ package body Checks is
begin
-- Do not insert if checks off, or if not checking validity
if Range_Checks_Suppressed (Etype (Expr))
or else (not Validity_Checks_On)
if not Validity_Checks_On
or else Range_Or_Validity_Checks_Suppressed (Expr)
then
return;
end if;
@ -4754,11 +5020,20 @@ package body Checks is
Exp := Expression (Exp);
end loop;
-- We are about to insert the validity check for Exp. We save and
-- reset the Do_Range_Check flag over this validity check, and then
-- put it back for the final original reference (Exp may be rewritten).
declare
DRC : constant Boolean := Do_Range_Check (Exp);
begin
Set_Do_Range_Check (Exp, False);
-- Insert the validity check. Note that we do this with validity
-- checks turned off, to avoid recursion, we do not want validity
-- checks on the validity checking code itself!
Validity_Checks_On := False;
Insert_Action
(Expr,
Make_Raise_Constraint_Error (Loc,
@ -4770,17 +5045,19 @@ package body Checks is
Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
Attribute_Name => Name_Valid)),
Reason => CE_Invalid_Data),
Suppress => All_Checks);
Suppress => Validity_Check);
-- If the expression is a a reference to an element of a bit-packed
-- array, it is rewritten as a renaming declaration. If the expression
-- is an actual in a call, it has not been expanded, waiting for the
-- proper point at which to do it. The same happens with renamings, so
-- that we have to force the expansion now. This non-local complication
-- is due to code in exp_ch2,adb, exp_ch4.adb and exp_ch6.adb.
-- array, then it is rewritten as a renaming declaration. If the
-- expression is an actual in a call, it has not been expanded,
-- waiting for the proper point at which to do it. The same happens
-- with renamings, so that we have to force the expansion now. This
-- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
-- and exp_ch6.adb.
if Is_Entity_Name (Exp)
and then Nkind (Parent (Entity (Exp))) = N_Object_Renaming_Declaration
and then Nkind (Parent (Entity (Exp))) =
N_Object_Renaming_Declaration
then
declare
Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
@ -4793,7 +5070,17 @@ package body Checks is
end;
end if;
Validity_Checks_On := True;
-- Put back the Do_Range_Check flag on the resulting (possibly
-- rewritten) expression.
-- Note: it might be thought that a validity check is not required
-- when a range check is present, but that's not the case, because
-- the back end is allowed to assume for the range check that the
-- operand is within its declared range (an assumption that validity
-- checking is all about NOT assuming!)
Set_Do_Range_Check (Exp, DRC);
end;
end Insert_Valid_Check;
----------------------------------
@ -5002,6 +5289,66 @@ package body Checks is
return Scope_Suppress (Range_Check);
end Range_Checks_Suppressed;
-----------------------------------------
-- Range_Or_Validity_Checks_Suppressed --
-----------------------------------------
-- Note: the coding would be simpler here if we simply made appropriate
-- calls to Range/Validity_Checks_Suppressed, but that would result in
-- duplicated checks which we prefer to avoid.
function Range_Or_Validity_Checks_Suppressed
(Expr : Node_Id) return Boolean
is
begin
-- Immediate return if scope checks suppressed for either check
if Scope_Suppress (Range_Check) or Scope_Suppress (Validity_Check) then
return True;
end if;
-- If no expression, that's odd, decide that checks are suppressed,
-- since we don't want anyone trying to do checks in this case, which
-- is most likely the result of some other error.
if No (Expr) then
return True;
end if;
-- Expression is present, so perform suppress checks on type
declare
Typ : constant Entity_Id := Etype (Expr);
begin
if Vax_Float (Typ) then
return True;
elsif Checks_May_Be_Suppressed (Typ)
and then (Is_Check_Suppressed (Typ, Range_Check)
or else
Is_Check_Suppressed (Typ, Validity_Check))
then
return True;
end if;
end;
-- If expression is an entity name, perform checks on this entity
if Is_Entity_Name (Expr) then
declare
Ent : constant Entity_Id := Entity (Expr);
begin
if Checks_May_Be_Suppressed (Ent) then
return Is_Check_Suppressed (Ent, Range_Check)
or else Is_Check_Suppressed (Ent, Validity_Check);
end if;
end;
end if;
-- If we fall through, no checks suppressed
return False;
end Range_Or_Validity_Checks_Suppressed;
-------------------
-- Remove_Checks --
-------------------
@ -6164,12 +6511,20 @@ package body Checks is
-- 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
-- meaning.
-- meaning. Similarly, if the entity is a discriminal,
-- there is no check to perform yet.
-- The same holds within a discriminated synchronized
-- type, where the discriminant may constrain a component
-- or an entry family.
if Nkind (LB) = N_Identifier
and then Ekind (Entity (LB)) = E_Discriminant
and then Denotes_Discriminant (LB, True)
then
if Current_Scope = Scope (Entity (LB))
or else Is_Concurrent_Type (Current_Scope)
or else Ekind (Entity (LB)) /= E_Discriminant
then
if Current_Scope = Scope (Entity (LB)) then
return Ret_Result;
else
LB :=
@ -6178,9 +6533,12 @@ package body Checks is
end if;
if Nkind (HB) = N_Identifier
and then Ekind (Entity (HB)) = E_Discriminant
and then Denotes_Discriminant (HB, True)
then
if Current_Scope = Scope (Entity (HB))
or else Is_Concurrent_Type (Current_Scope)
or else Ekind (Entity (HB)) /= E_Discriminant
then
if Current_Scope = Scope (Entity (HB)) then
return Ret_Result;
else
HB :=
@ -6499,4 +6857,31 @@ package body Checks is
return Scope_Suppress (Tag_Check);
end Tag_Checks_Suppressed;
--------------------------
-- Validity_Check_Range --
--------------------------
procedure Validity_Check_Range (N : Node_Id) is
begin
if Validity_Checks_On and Validity_Check_Operands then
if Nkind (N) = N_Range then
Ensure_Valid (Low_Bound (N));
Ensure_Valid (High_Bound (N));
end if;
end if;
end Validity_Check_Range;
--------------------------------
-- Validity_Checks_Suppressed --
--------------------------------
function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Validity_Check);
else
return Scope_Suppress (Validity_Check);
end if;
end Validity_Checks_Suppressed;
end Checks;

35
gcc/ada/checks.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
@ -47,6 +47,7 @@ package Checks is
function Access_Checks_Suppressed (E : Entity_Id) return Boolean;
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean;
function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean;
function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean;
function Division_Checks_Suppressed (E : Entity_Id) return Boolean;
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean;
@ -56,13 +57,13 @@ package Checks is
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
-- These functions check to see if the named check is suppressed,
-- either by an active scope suppress setting, or because the check
-- has been specifically suppressed for the given entity. If no entity
-- is relevant for the current check, then Empty is used as an argument.
-- Note: the reason we insist on specifying Empty is to force the
-- caller to think about whether there is any relevant entity that
-- should be checked.
function Validity_Checks_Suppressed (E : Entity_Id) return Boolean;
-- These functions check to see if the named check is suppressed, either
-- by an active scope suppress setting, or because the check has been
-- specifically suppressed for the given entity. If no entity is relevant
-- for the current check, then Empty is used as an argument. Note: the
-- reason we insist on specifying Empty is to force the caller to think
-- about whether there is any relevant entity that should be checked.
-- General note on following checks. These checks are always active if
-- Expander_Active and not Inside_A_Generic. They are inactive and have
@ -80,12 +81,14 @@ package Checks is
-- the object denoted by the access parameter is not deeper than the
-- level of the type Typ. Program_Error is raised if the check fails.
procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id);
-- E is the entity for an object. If there is an address clause for
-- this entity, and checks are enabled, then this procedure generates
-- a check that the specified address has an alignment consistent with
-- the alignment of the object, raising PE if this is not the case. The
-- resulting check (if one is generated) is inserted before node N.
procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id);
-- E is the entity for an object which has an address clause. If checks
-- are enabled, then this procedure generates a check that the specified
-- address has an alignment consistent with the alignment of the object,
-- raising PE if this is not the case. The resulting check (if one is
-- generated) is inserted before node N. check is also made for the case of
-- a clear overlay situation that the size of the overlaying object is not
-- larger than the overlaid object.
procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id);
-- N is the node for an object declaration that declares an object of
@ -625,6 +628,10 @@ package Checks is
-- conditionally (on the right side of And Then/Or Else. This call
-- removes only embedded checks (Do_Range_Check, Do_Overflow_Check).
procedure Validity_Check_Range (N : Node_Id);
-- If N is an N_Range node, then Ensure_Valid is called on its bounds,
-- if validity checking of operands is enabled.
private
type Check_Result is array (Positive range 1 .. 2) of Node_Id;

5
gcc/ada/treepr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
@ -886,9 +886,8 @@ package body Treepr is
if Nkind (N) in N_Op
or else Nkind (N) = N_And_Then
or else Nkind (N) = N_In
or else Nkind (N) = N_Not_In
or else Nkind (N) = N_Or_Else
or else Nkind (N) in N_Membership_Test
then
-- Print Left_Opnd if present