Skip to content

R
riscv-gcc-1
Commit 11b4899f by Javier Miranda Committed by Arnaud Charlet
Options

checks.ads, checks.adb (Apply_Address_Clause_Check): Handle case in which the… 

checks.ads, checks.adb (Apply_Address_Clause_Check): Handle case in which the address-clause is applied to in-mode actuals (allowed...

2007-04-20  Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* checks.ads, checks.adb (Apply_Address_Clause_Check): Handle case in
	which the address-clause is applied to in-mode actuals (allowed by
	13.1(22)).
	(Apply_Discriminant_Check): Do not generate a check if the type is
	constrained by a current instance.
	(Activate_Division_Check): New procedure
	(Activate_Overflow_Check): New procedure
	(Activate_Range_Check): New procedure
	Call these new Activate procedures instead of setting flags directly
	(Apply_Array_Size_Check): Removed, no longer needed.
	Code clean up: remove obsolete code related to GCC 2.
	(Get_E_Length): Protect against bomb in case scope is standard
	(Selected_Range_Checks): If the node to be checked is a conversion to
	an unconstrained array type, and the expression is a slice, use the
	bounds of the slice to construct the required constraint checks.
	Improve NOT NULL error messages
	(Apply_Constraint_Check): If the context is a null-excluding access
	type, diagnose properly the literal null.

From-SVN: r125388
parent 47eb2d8d
Showing with 149 additions and 311 deletions
gcc/ada/checks.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,12 +29,14 @@ with Debug; use Debug; ...@@ -29,12 +29,14 @@ with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Exp_Ch2; use Exp_Ch2; with Exp_Ch2; use Exp_Ch2;
with Exp_Ch11; use Exp_Ch11;
with Exp_Pakd; use Exp_Pakd; with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Elists; use Elists; with Elists; use Elists;
with Eval_Fat; use Eval_Fat; with Eval_Fat; use Eval_Fat;
with Freeze; use Freeze; with Freeze; use Freeze;
with Lib; use Lib; with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
with Opt; use Opt; with Opt; use Opt;
...@@ -336,6 +338,36 @@ package body Checks is ...@@ -336,6 +338,36 @@ package body Checks is
end if; end if;
end Accessibility_Checks_Suppressed; end Accessibility_Checks_Suppressed;
-----------------------------
-- Activate_Division_Check --
-----------------------------
procedure Activate_Division_Check (N : Node_Id) is
begin
Set_Do_Division_Check (N, True);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Division_Check;
-----------------------------
-- Activate_Overflow_Check --
-----------------------------
procedure Activate_Overflow_Check (N : Node_Id) is
begin
Set_Do_Overflow_Check (N, True);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Overflow_Check;
--------------------------
-- Activate_Range_Check --
--------------------------
procedure Activate_Range_Check (N : Node_Id) is
begin
Set_Do_Range_Check (N, True);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Range_Check;
--------------------------------- ---------------------------------
-- Alignment_Checks_Suppressed -- -- Alignment_Checks_Suppressed --
--------------------------------- ---------------------------------
...@@ -674,12 +706,17 @@ package body Checks is ...@@ -674,12 +706,17 @@ package body Checks is
else else
-- If the original expression is a non-static constant, use the -- If the original expression is a non-static constant, use the
-- name of the constant itself rather than duplicating its -- name of the constant itself rather than duplicating its
-- defining expression, which was extracted above.. -- defining expression, which was extracted above.
if Is_Entity_Name (Expression (AC)) -- Note: Expr is empty if the address-clause is applied to in-mode
and then Ekind (Entity (Expression (AC))) = E_Constant -- actuals (allowed by 13.1(22)).
and then
Nkind (Parent (Entity (Expression (AC)))) = N_Object_Declaration if not Present (Expr)
or else
(Is_Entity_Name (Expression (AC))
and then Ekind (Entity (Expression (AC))) = E_Constant
and then Nkind (Parent (Entity (Expression (AC))))
= N_Object_Declaration)
then then
Expr := New_Copy_Tree (Expression (AC)); Expr := New_Copy_Tree (Expression (AC));
else else
...@@ -738,8 +775,11 @@ package body Checks is ...@@ -738,8 +775,11 @@ package body Checks is
begin begin
-- Skip this if overflow checks are done in back end, or the overflow -- 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. -- flag is not set anyway, or we are not doing code expansion.
-- Special case CLI target, where arithmetic overflow checks can be
-- performed for integer and long_integer
if Backend_Overflow_Checks_On_Target if Backend_Overflow_Checks_On_Target
or else (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size)
or else not Do_Overflow_Check (N) or else not Do_Overflow_Check (N)
or else not Expander_Active or else not Expander_Active
then then
...@@ -859,266 +899,6 @@ package body Checks is ...@@ -859,266 +899,6 @@ package body Checks is
end Apply_Arithmetic_Overflow_Check; end Apply_Arithmetic_Overflow_Check;
---------------------------- ----------------------------
-- Apply_Array_Size_Check --
----------------------------
-- 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, and we do not bother to generate
-- any front end 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);
Ent : constant Entity_Id := Defining_Identifier (N);
Decl : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Lob : Uint;
Hib : Uint;
Siz : Uint;
Xtyp : Entity_Id;
Indx : Node_Id;
Sizx : Node_Id;
Code : Node_Id;
Static : Boolean := True;
-- Set false if any index subtye bound is non-static
Umark : constant Uintp.Save_Mark := Uintp.Mark;
-- We can throw away all the Uint computations here, since they are done
-- only to generate boolean test results.
Check_Siz : Uint;
-- Size to check against
function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
-- Determines if Decl is an address clause or Import/Interface pragma
-- that references the defining identifier of the current declaration.
--------------------------
-- Is_Address_Or_Import --
--------------------------
function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
begin
if Nkind (Decl) = N_At_Clause then
return Chars (Identifier (Decl)) = Chars (Ent);
elsif Nkind (Decl) = N_Attribute_Definition_Clause then
return
Chars (Decl) = Name_Address
and then
Nkind (Name (Decl)) = N_Identifier
and then
Chars (Name (Decl)) = Chars (Ent);
elsif Nkind (Decl) = N_Pragma then
if (Chars (Decl) = Name_Import
or else
Chars (Decl) = Name_Interface)
and then Present (Pragma_Argument_Associations (Decl))
then
declare
F : constant Node_Id :=
First (Pragma_Argument_Associations (Decl));
begin
return
Present (F)
and then
Present (Next (F))
and then
Nkind (Expression (Next (F))) = N_Identifier
and then
Chars (Expression (Next (F))) = Chars (Ent);
end;
else
return False;
end if;
else
return False;
end if;
end Is_Address_Or_Import;
-- Start of processing for Apply_Array_Size_Check
begin
-- Do size check on local arrays. We only need this in the GCC 2 case,
-- since in GCC 3, we expect the back end to properly handle things.
-- This routine can be removed when we baseline GNAT 3.
-- Shouldn't we remove GCC 2 crud at this stage ???
if Opt.GCC_Version >= 3 then
return;
end if;
-- 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
-- that's too late, we have already built the object to be the right
-- size, and if it's too large, too bad!
if Inside_Init_Proc then
return;
end if;
-- Look head for pragma interface/import or address clause applying to
-- this entity. If found, we suppress the check entirely. For now we
-- only look ahead 20 declarations to stop this becoming too slow Note
-- that eventually this whole routine gets moved to gigi.
Decl := N;
for Ctr in 1 .. 20 loop
Next (Decl);
exit when No (Decl);
if Is_Address_Or_Import (Decl) then
return;
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.
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;
-- Otherwise get bounds values
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 Is_Static_Expression (Hi) then
Hib := Expr_Value (Hi);
else
Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
Static := False;
end if;
Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
Next_Index (Indx);
end loop;
-- 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 Is_Subprogram (Scope (Ent)) then
Check_Siz := Uint_2 ** 27;
else
Check_Siz := Uint_2 ** 31;
end if;
-- If we have all static bounds and Siz is too large, then we know we
-- have a storage error right now, so generate message
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;
-- Case of component size known at compile time. If the array size is
-- definitely in range, then we do not need a check.
if Known_Esize (Ctyp)
and then Siz * Esize (Ctyp) < Check_Siz
then
Uintp.Release (Umark);
return;
end if;
-- Here if a dynamic check is required
-- 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.
Uintp.Release (Umark);
Sizx :=
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;
-- Emit the check
Code :=
Make_Raise_Storage_Error (Loc,
Condition =>
Make_Op_Ge (Loc,
Left_Opnd => Sizx,
Right_Opnd =>
Make_Integer_Literal (Loc,
Intval => Check_Siz)),
Reason => SE_Object_Too_Large);
Set_Size_Check_Code (Defining_Identifier (N), Code);
Insert_Action (N, Code, Suppress => All_Checks);
end Apply_Array_Size_Check;
----------------------------
-- Apply_Constraint_Check -- -- Apply_Constraint_Check --
---------------------------- ----------------------------
...@@ -1174,7 +954,9 @@ package body Checks is ...@@ -1174,7 +954,9 @@ package body Checks is
-- No checks necessary if expression statically null -- No checks necessary if expression statically null
if Nkind (N) = N_Null then if Nkind (N) = N_Null then
null; if Can_Never_Be_Null (Typ) then
Install_Null_Excluding_Check (N);
end if;
-- No sliding possible on access to arrays -- No sliding possible on access to arrays
...@@ -1191,8 +973,14 @@ package body Checks is ...@@ -1191,8 +973,14 @@ package body Checks is
Apply_Discriminant_Check (N, Typ); Apply_Discriminant_Check (N, Typ);
end if; end if;
-- Apply the the 2005 Null_Excluding check. Note that we do not apply
-- this check if the constraint node is illegal, as shown by having
-- an error posted. This additional guard prevents cascaded errors
-- and compiler aborts on illegal programs involving Ada 2005 checks.
if Can_Never_Be_Null (Typ) if Can_Never_Be_Null (Typ)
and then not Can_Never_Be_Null (Etype (N)) and then not Can_Never_Be_Null (Etype (N))
and then not Error_Posted (N)
then then
Install_Null_Excluding_Check (N); Install_Null_Excluding_Check (N);
end if; end if;
...@@ -1439,6 +1227,18 @@ package body Checks is ...@@ -1439,6 +1227,18 @@ package body Checks is
ItemS := Node (DconS); ItemS := Node (DconS);
ItemT := Node (DconT); ItemT := Node (DconT);
-- For a discriminated component type constrained by the
-- current instance of an enclosing type, there is no
-- applicable discriminant check.
if Nkind (ItemT) = N_Attribute_Reference
and then Is_Access_Type (Etype (ItemT))
and then Is_Entity_Name (Prefix (ItemT))
and then Is_Type (Entity (Prefix (ItemT)))
then
return;
end if;
exit when exit when
not Is_OK_Static_Expression (ItemS) not Is_OK_Static_Expression (ItemS)
or else or else
...@@ -2166,15 +1966,14 @@ package body Checks is ...@@ -2166,15 +1966,14 @@ package body Checks is
-- We do this by replacing the if statement by a null statement -- We do this by replacing the if statement by a null statement
elsif Do_Static or else not Checks_On then elsif Do_Static or else not Checks_On then
Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc)); Rewrite (R_Cno, Make_Null_Statement (Loc));
end if; end if;
else else
Install_Static_Check (R_Cno, Loc); Install_Static_Check (R_Cno, Loc);
end if; end if;
end loop; end loop;
end Apply_Selected_Length_Checks; end Apply_Selected_Length_Checks;
--------------------------------- ---------------------------------
...@@ -2258,6 +2057,7 @@ package body Checks is ...@@ -2258,6 +2057,7 @@ package body Checks is
-- We do this by replacing the if statement by a null statement -- We do this by replacing the if statement by a null statement
elsif Do_Static or else not Checks_On then elsif Do_Static or else not Checks_On then
Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc)); Rewrite (R_Cno, Make_Null_Statement (Loc));
end if; end if;
...@@ -2351,7 +2151,7 @@ package body Checks is ...@@ -2351,7 +2151,7 @@ package body Checks is
and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK) and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
and then not Float_To_Int and then not Float_To_Int
then then
Set_Do_Overflow_Check (N); Activate_Overflow_Check (N);
end if; end if;
if not Range_Checks_Suppressed (Target_Type) if not Range_Checks_Suppressed (Target_Type)
...@@ -2838,8 +2638,7 @@ package body Checks is ...@@ -2838,8 +2638,7 @@ package body Checks is
if not Is_Access_Type (Typ) then if not Is_Access_Type (Typ) then
Error_Msg_N Error_Msg_N
("null-exclusion must be applied to an access type", ("`NOT NULL` allowed only for an access type", Error_Node);
Error_Node);
-- Enforce legality rule RM 3.10(14/1): A null exclusion can only -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
-- be applied to a [sub]type that does not exclude null already. -- be applied to a [sub]type that does not exclude null already.
...@@ -2851,9 +2650,9 @@ package body Checks is ...@@ -2851,9 +2650,9 @@ package body Checks is
and then not Is_Itype (Typ) and then not Is_Itype (Typ)
then then
Error_Msg_N Error_Msg_NE
("null-exclusion cannot be applied to a null excluding type", ("`NOT NULL` not allowed (& already excludes null)",
Error_Node); Error_Node, Typ);
end if; end if;
end if; end if;
...@@ -3498,7 +3297,7 @@ package body Checks is ...@@ -3498,7 +3297,7 @@ package body Checks is
w ("Enable_Overflow_Check for node ", Int (N)); w ("Enable_Overflow_Check for node ", Int (N));
Write_Str (" Source location = "); Write_Str (" Source location = ");
wl (Sloc (N)); wl (Sloc (N));
pg (N); pg (Union_Id (N));
end if; end if;
-- Nothing to do if the range of the result is known OK. We skip this -- Nothing to do if the range of the result is known OK. We skip this
...@@ -3549,7 +3348,7 @@ package body Checks is ...@@ -3549,7 +3348,7 @@ package body Checks is
or else not Is_Discrete_Type (Etype (N)) or else not Is_Discrete_Type (Etype (N))
or else Num_Saved_Checks = Saved_Checks'Last or else Num_Saved_Checks = Saved_Checks'Last
then then
Set_Do_Overflow_Check (N, True); Activate_Overflow_Check (N);
if Debug_Flag_CC then if Debug_Flag_CC then
w ("Optimization off"); w ("Optimization off");
...@@ -3584,7 +3383,7 @@ package body Checks is ...@@ -3584,7 +3383,7 @@ package body Checks is
-- If check is not of form to optimize, then set flag and we are done -- If check is not of form to optimize, then set flag and we are done
if not OK then if not OK then
Set_Do_Overflow_Check (N, True); Activate_Overflow_Check (N);
return; return;
end if; end if;
...@@ -3600,7 +3399,7 @@ package body Checks is ...@@ -3600,7 +3399,7 @@ package body Checks is
-- Here we will make a new entry for the new check -- Here we will make a new entry for the new check
Set_Do_Overflow_Check (N, True); Activate_Overflow_Check (N);
Num_Saved_Checks := Num_Saved_Checks + 1; Num_Saved_Checks := Num_Saved_Checks + 1;
Saved_Checks (Num_Saved_Checks) := Saved_Checks (Num_Saved_Checks) :=
(Killed => False, (Killed => False,
...@@ -3625,7 +3424,7 @@ package body Checks is ...@@ -3625,7 +3424,7 @@ package body Checks is
exception exception
when others => when others =>
Set_Do_Overflow_Check (N, True); Activate_Overflow_Check (N);
if Debug_Flag_CC then if Debug_Flag_CC then
w (" exception occurred, overflow flag set"); w (" exception occurred, overflow flag set");
...@@ -3697,7 +3496,7 @@ package body Checks is ...@@ -3697,7 +3496,7 @@ package body Checks is
w ("Enable_Range_Check for node ", Int (N)); w ("Enable_Range_Check for node ", Int (N));
Write_Str (" Source location = "); Write_Str (" Source location = ");
wl (Sloc (N)); wl (Sloc (N));
pg (N); pg (Union_Id (N));
end if; end if;
-- If not in optimizing mode, set flag and we are done. We are also done -- If not in optimizing mode, set flag and we are done. We are also done
...@@ -3712,7 +3511,7 @@ package body Checks is ...@@ -3712,7 +3511,7 @@ package body Checks is
or else not Is_Discrete_Type (Etype (N)) or else not Is_Discrete_Type (Etype (N))
or else Num_Saved_Checks = Saved_Checks'Last or else Num_Saved_Checks = Saved_Checks'Last
then then
Set_Do_Range_Check (N, True); Activate_Range_Check (N);
if Debug_Flag_CC then if Debug_Flag_CC then
w ("Optimization off"); w ("Optimization off");
...@@ -3752,7 +3551,7 @@ package body Checks is ...@@ -3752,7 +3551,7 @@ package body Checks is
-- may be redundant. -- may be redundant.
if not Is_Constrained (Atyp) then if not Is_Constrained (Atyp) then
Set_Do_Range_Check (N, True); Activate_Range_Check (N);
return; return;
end if; end if;
...@@ -3762,7 +3561,7 @@ package body Checks is ...@@ -3762,7 +3561,7 @@ package body Checks is
elsif Nkind (Prefix (P)) = N_Explicit_Dereference elsif Nkind (Prefix (P)) = N_Explicit_Dereference
and then not Is_Constrained (Atyp) and then not Is_Constrained (Atyp)
then then
Set_Do_Range_Check (N, True); Activate_Range_Check (N);
return; return;
end if; end if;
...@@ -3786,7 +3585,7 @@ package body Checks is ...@@ -3786,7 +3585,7 @@ package body Checks is
w (" target type not found, flag set"); w (" target type not found, flag set");
end if; end if;
Set_Do_Range_Check (N, True); Activate_Range_Check (N);
return; return;
end if; end if;
...@@ -3821,7 +3620,7 @@ package body Checks is ...@@ -3821,7 +3620,7 @@ package body Checks is
w (" expression not of optimizable type, flag set"); w (" expression not of optimizable type, flag set");
end if; end if;
Set_Do_Range_Check (N, True); Activate_Range_Check (N);
return; return;
end if; end if;
...@@ -3837,7 +3636,7 @@ package body Checks is ...@@ -3837,7 +3636,7 @@ package body Checks is
-- Here we will make a new entry for the new check -- Here we will make a new entry for the new check
Set_Do_Range_Check (N, True); Activate_Range_Check (N);
Num_Saved_Checks := Num_Saved_Checks + 1; Num_Saved_Checks := Num_Saved_Checks + 1;
Saved_Checks (Num_Saved_Checks) := Saved_Checks (Num_Saved_Checks) :=
(Killed => False, (Killed => False,
...@@ -3853,7 +3652,7 @@ package body Checks is ...@@ -3853,7 +3652,7 @@ package body Checks is
pid (Ofs); pid (Ofs);
w (" Check_Type = R"); w (" Check_Type = R");
w (" Target_Type = ", Int (Ttyp)); w (" Target_Type = ", Int (Ttyp));
pg (Ttyp); pg (Union_Id (Ttyp));
end if; end if;
-- If we get an exception, then something went wrong, probably because of -- If we get an exception, then something went wrong, probably because of
...@@ -3863,7 +3662,7 @@ package body Checks is ...@@ -3863,7 +3662,7 @@ package body Checks is
exception exception
when others => when others =>
Set_Do_Range_Check (N, True); Activate_Range_Check (N);
if Debug_Flag_CC then if Debug_Flag_CC then
w (" exception occurred, range flag set"); w (" exception occurred, range flag set");
...@@ -5077,6 +4876,9 @@ package body Checks is ...@@ -5077,6 +4876,9 @@ package body Checks is
-- operand is within its declared range (an assumption that validity -- operand is within its declared range (an assumption that validity
-- checking is all about NOT assuming!) -- checking is all about NOT assuming!)
-- Note: no need to worry about Possible_Local_Raise here, it will
-- already have been called if original node has Do_Range_Check set.
Set_Do_Range_Check (Exp, DRC); Set_Do_Range_Check (Exp, DRC);
end; end;
end Insert_Valid_Check; end Insert_Valid_Check;
...@@ -5508,7 +5310,7 @@ package body Checks is ...@@ -5508,7 +5310,7 @@ package body Checks is
------------------ ------------------
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
Pt : constant Entity_Id := Scope (Scope (E)); SE : constant Entity_Id := Scope (E);
N : Node_Id; N : Node_Id;
E1 : Entity_Id := E; E1 : Entity_Id := E;
...@@ -5529,12 +5331,12 @@ package body Checks is ...@@ -5529,12 +5331,12 @@ package body Checks is
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
Intval => String_Literal_Length (E1)); Intval => String_Literal_Length (E1));
elsif Ekind (Pt) = E_Protected_Type elsif SE /= Standard_Standard
and then Has_Discriminants (Pt) and then Ekind (Scope (SE)) = E_Protected_Type
and then Has_Completion (Pt) and then Has_Discriminants (Scope (SE))
and then Has_Completion (Scope (SE))
and then not Inside_Init_Proc and then not Inside_Init_Proc
then then
-- If the type whose length is needed is a private component -- If the type whose length is needed is a private component
-- constrained by a discriminant, we must expand the 'Length -- constrained by a discriminant, we must expand the 'Length
-- attribute into an explicit computation, using the discriminal -- attribute into an explicit computation, using the discriminal
...@@ -6756,37 +6558,52 @@ package body Checks is ...@@ -6756,37 +6558,52 @@ package body Checks is
declare declare
Opnd_Index : Node_Id; Opnd_Index : Node_Id;
Targ_Index : Node_Id; Targ_Index : Node_Id;
Opnd_Range : Node_Id;
begin begin
Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node)); Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
Targ_Index := First_Index (T_Typ); Targ_Index := First_Index (T_Typ);
while Opnd_Index /= Empty loop
if Nkind (Opnd_Index) = N_Range then while Present (Opnd_Index) loop
-- If the index is a range, use its bounds. If it is an
-- entity (as will be the case if it is a named subtype
-- or an itype created for a slice) retrieve its range.
if Is_Entity_Name (Opnd_Index)
and then Is_Type (Entity (Opnd_Index))
then
Opnd_Range := Scalar_Range (Entity (Opnd_Index));
else
Opnd_Range := Opnd_Index;
end if;
if Nkind (Opnd_Range) = N_Range then
if Is_In_Range if Is_In_Range
(Low_Bound (Opnd_Index), Etype (Targ_Index)) (Low_Bound (Opnd_Range), Etype (Targ_Index))
and then and then
Is_In_Range Is_In_Range
(High_Bound (Opnd_Index), Etype (Targ_Index)) (High_Bound (Opnd_Range), Etype (Targ_Index))
then then
null; null;
-- If null range, no check needed -- If null range, no check needed
elsif elsif
Compile_Time_Known_Value (High_Bound (Opnd_Index)) Compile_Time_Known_Value (High_Bound (Opnd_Range))
and then and then
Compile_Time_Known_Value (Low_Bound (Opnd_Index)) Compile_Time_Known_Value (Low_Bound (Opnd_Range))
and then and then
Expr_Value (High_Bound (Opnd_Index)) < Expr_Value (High_Bound (Opnd_Range)) <
Expr_Value (Low_Bound (Opnd_Index)) Expr_Value (Low_Bound (Opnd_Range))
then then
null; null;
elsif Is_Out_Of_Range elsif Is_Out_Of_Range
(Low_Bound (Opnd_Index), Etype (Targ_Index)) (Low_Bound (Opnd_Range), Etype (Targ_Index))
or else or else
Is_Out_Of_Range Is_Out_Of_Range
(High_Bound (Opnd_Index), Etype (Targ_Index)) (High_Bound (Opnd_Range), Etype (Targ_Index))
then then
Add_Check Add_Check
(Compile_Time_Constraint_Error (Compile_Time_Constraint_Error
...@@ -6796,7 +6613,7 @@ package body Checks is ...@@ -6796,7 +6613,7 @@ package body Checks is
Evolve_Or_Else Evolve_Or_Else
(Cond, (Cond,
Discrete_Range_Cond Discrete_Range_Cond
(Opnd_Index, Etype (Targ_Index))); (Opnd_Range, Etype (Targ_Index)));
end if; end if;
end if; end if;
......
gcc/ada/checks.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -65,6 +65,32 @@ package Checks is ...@@ -65,6 +65,32 @@ package Checks is
-- reason we insist on specifying Empty is to force the caller to think -- reason we insist on specifying Empty is to force the caller to think
-- about whether there is any relevant entity that should be checked. -- about whether there is any relevant entity that should be checked.
-------------------------------------------
-- Procedures to Activate Checking Flags --
-------------------------------------------
procedure Activate_Division_Check (N : Node_Id);
pragma Inline (Activate_Division_Check);
-- Sets Do_Division_Check flag in node N, and handles possible local raise.
-- Always call this routine rather than calling Set_Do_Division_Check to
-- set an explicit value of True, to ensure handling the local raise case.
procedure Activate_Overflow_Check (N : Node_Id);
pragma Inline (Activate_Overflow_Check);
-- Sets Do_Overflow_Check flag in node N, and handles possible local raise.
-- Always call this routine rather than calling Set_Do_Overflow_Check to
-- set an explicit value of True, to ensure handling the local raise case.
procedure Activate_Range_Check (N : Node_Id);
pragma Inline (Activate_Range_Check);
-- Sets Do_Range_Check flag in node N, and handles possible local raise
-- Always call this routine rather than calling Set_Do_Range_Check to
-- set an explicit value of True, to ensure handling the local raise case.
--------------------------------
-- Procedures to Apply Checks --
--------------------------------
-- General note on following checks. These checks are always active if -- General note on following checks. These checks are always active if
-- Expander_Active and not Inside_A_Generic. They are inactive and have -- Expander_Active and not Inside_A_Generic. They are inactive and have
-- no effect Inside_A_Generic. In the case where not Expander_Active -- no effect Inside_A_Generic. In the case where not Expander_Active
...@@ -90,11 +116,6 @@ package Checks is ...@@ -90,11 +116,6 @@ package Checks is
-- a clear overlay situation that the size of the overlaying object is not -- a clear overlay situation that the size of the overlaying object is not
-- larger than the overlaid object. -- 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
-- array type Typ. This routine generates, if necessary, a check that
-- the size of the array is not too large, raising Storage_Error if so.
procedure Apply_Arithmetic_Overflow_Check (N : Node_Id); procedure Apply_Arithmetic_Overflow_Check (N : Node_Id);
-- Given a binary arithmetic operator (+ - *) expand a software integer -- Given a binary arithmetic operator (+ - *) expand a software integer
-- overflow check using range checks on a larger checking type or a call -- overflow check using range checks on a larger checking type or a call
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment